| File: | lib/Netspoc.pm |
| Coverage: | 81.3% |
| line | stmt | bran | cond | sub | pod | time | code |
|---|---|---|---|---|---|---|---|
| 1 | package Netspoc; | ||||||
| 2 | |||||||
| 3 - 27 | =head1 NAME Netspoc - A Network Security Policy Compiler =head1 COPYRIGHT AND DISCLAIMER (c) 2015 by Heinz Knutzen <heinz.knutzen@googlemail.com> http://hknutzen.github.com/Netspoc This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. =cut | ||||||
| 28 | |||||||
| 29 | 70 70 70 | 233 71 1656 | use strict; | ||||
| 30 | 70 70 70 | 257 67 1544 | use warnings; | ||||
| 31 | 70 70 70 | 16874 134 4632 | use Module::Load::Conditional qw(can_load); | ||||
| 32 | my $can_json = can_load( modules => {JSON => 0.0} ) and JSON->import(); | ||||||
| 33 | 70 70 70 | 11955 115 228 | use open qw(:std :utf8); | ||||
| 34 | 70 70 70 | 16032 94 5311 | use Encode; | ||||
| 35 | my $filename_encode = 'UTF-8'; | ||||||
| 36 | |||||||
| 37 | # VERSION: inserted by DZP::OurPkgVersion | ||||||
| 38 | my $program = 'Network Security Policy Compiler'; | ||||||
| 39 | my $version = __PACKAGE__->VERSION || 'devel'; | ||||||
| 40 | |||||||
| 41 | 70 70 70 | 272 74 1757714 | use Exporter; | ||||
| 42 | our @ISA = qw(Exporter); | ||||||
| 43 | our @EXPORT = qw( | ||||||
| 44 | %routers | ||||||
| 45 | %interfaces | ||||||
| 46 | %networks | ||||||
| 47 | %hosts | ||||||
| 48 | %owners | ||||||
| 49 | %areas | ||||||
| 50 | %pathrestrictions | ||||||
| 51 | %groups | ||||||
| 52 | %protocols | ||||||
| 53 | %protocolgroups | ||||||
| 54 | %services | ||||||
| 55 | %isakmp | ||||||
| 56 | %ipsec | ||||||
| 57 | %crypto | ||||||
| 58 | %expanded_rules | ||||||
| 59 | $error_counter | ||||||
| 60 | store_description | ||||||
| 61 | fast_mode | ||||||
| 62 | get_config_keys | ||||||
| 63 | get_config_pattern | ||||||
| 64 | check_config_pair | ||||||
| 65 | read_config | ||||||
| 66 | set_config | ||||||
| 67 | info | ||||||
| 68 | progress | ||||||
| 69 | abort_on_error | ||||||
| 70 | set_abort_immediately | ||||||
| 71 | err_msg | ||||||
| 72 | fatal_err | ||||||
| 73 | unique | ||||||
| 74 | equal | ||||||
| 75 | read_ip | ||||||
| 76 | print_ip | ||||||
| 77 | show_version | ||||||
| 78 | split_typed_name | ||||||
| 79 | is_network | ||||||
| 80 | is_router | ||||||
| 81 | is_interface | ||||||
| 82 | is_host | ||||||
| 83 | is_subnet | ||||||
| 84 | is_every | ||||||
| 85 | is_group | ||||||
| 86 | is_protocolgroup | ||||||
| 87 | is_objectgroup | ||||||
| 88 | is_chain | ||||||
| 89 | is_autointerface | ||||||
| 90 | read_netspoc | ||||||
| 91 | read_file | ||||||
| 92 | read_file_or_dir | ||||||
| 93 | show_read_statistics | ||||||
| 94 | order_protocols | ||||||
| 95 | link_topology | ||||||
| 96 | mark_disabled | ||||||
| 97 | set_zone | ||||||
| 98 | set_service_owner | ||||||
| 99 | expand_services | ||||||
| 100 | expand_crypto | ||||||
| 101 | check_unused_groups | ||||||
| 102 | setpath | ||||||
| 103 | path_walk | ||||||
| 104 | find_active_routes_and_statics | ||||||
| 105 | check_supernet_rules | ||||||
| 106 | optimize_and_warn_deleted | ||||||
| 107 | distribute_nat_info | ||||||
| 108 | gen_reverse_rules | ||||||
| 109 | mark_secondary_rules | ||||||
| 110 | rules_distribution | ||||||
| 111 | local_optimization | ||||||
| 112 | check_output_dir | ||||||
| 113 | print_code ); | ||||||
| 114 | |||||||
| 115 | #################################################################### | ||||||
| 116 | # User configurable options. | ||||||
| 117 | #################################################################### | ||||||
| 118 | |||||||
| 119 | # Valid values: | ||||||
| 120 | # - Default: 0|1 | ||||||
| 121 | # - Option with name "check_*": 0,1,'warn' | ||||||
| 122 | # - 0: no check | ||||||
| 123 | # - 1: throw an error if check fails | ||||||
| 124 | # - warn: print warning if check fails | ||||||
| 125 | # - Option with name "max_*": integer | ||||||
| 126 | # Other: string | ||||||
| 127 | our %config = ( | ||||||
| 128 | |||||||
| 129 | # Check for unused groups and protocolgroups. | ||||||
| 130 | check_unused_groups => 'warn', | ||||||
| 131 | |||||||
| 132 | # Check for unused protocol definitions. | ||||||
| 133 | check_unused_protocols => 0, | ||||||
| 134 | |||||||
| 135 | # Allow subnets only | ||||||
| 136 | # - if the enclosing network is marked as 'has_subnets' or | ||||||
| 137 | # - if the subnet is marked as 'subnet_of' | ||||||
| 138 | check_subnets => 'warn', | ||||||
| 139 | |||||||
| 140 | # Check for unenforceable rules, i.e. no managed device between src and dst. | ||||||
| 141 | check_unenforceable => 'warn', | ||||||
| 142 | |||||||
| 143 | # Check for duplicate rules. | ||||||
| 144 | check_duplicate_rules => 'warn', | ||||||
| 145 | |||||||
| 146 | # Check for redundant rules. | ||||||
| 147 | check_redundant_rules => 'warn', | ||||||
| 148 | |||||||
| 149 | # Check for services where owner can't be derived. | ||||||
| 150 | check_service_unknown_owner => 0, | ||||||
| 151 | |||||||
| 152 | # Check for services where multiple owners have been derived. | ||||||
| 153 | check_service_multi_owner => 'warn', | ||||||
| 154 | |||||||
| 155 | # Check for missing supernet rules. | ||||||
| 156 | check_supernet_rules => 'warn', | ||||||
| 157 | |||||||
| 158 | # Check for transient supernet rules. | ||||||
| 159 | check_transient_supernet_rules => 'warn', | ||||||
| 160 | |||||||
| 161 | # Optimize the number of routing entries per router: | ||||||
| 162 | # For each router find the hop, where the largest | ||||||
| 163 | # number of routing entries points to | ||||||
| 164 | # and replace them with a single default route. | ||||||
| 165 | # This is only applicable for internal networks | ||||||
| 166 | # which have no default route to the internet. | ||||||
| 167 | auto_default_route => 1, | ||||||
| 168 | |||||||
| 169 | # Add comments to generated code. | ||||||
| 170 | comment_acls => 0, | ||||||
| 171 | comment_routes => 0, | ||||||
| 172 | |||||||
| 173 | # Ignore these names when reading directories: | ||||||
| 174 | # - CVS and RCS directories | ||||||
| 175 | # - CVS working files | ||||||
| 176 | # - Editor backup files: emacs: *~ | ||||||
| 177 | ignore_files => '^(CVS|RCS|\.#.*|.*~)$', | ||||||
| 178 | |||||||
| 179 | # Abort after this many errors. | ||||||
| 180 | max_errors => 10, | ||||||
| 181 | |||||||
| 182 | # Print progress messages. | ||||||
| 183 | verbose => 1, | ||||||
| 184 | |||||||
| 185 | # Print progress messages with time stamps. | ||||||
| 186 | # Print "finished" with time stamp when finished. | ||||||
| 187 | time_stamps => 0, | ||||||
| 188 | ); | ||||||
| 189 | |||||||
| 190 | # Valid values for config options in %config. | ||||||
| 191 | # Key is prefix or string "default". | ||||||
| 192 | # Value is pattern for checking valid values. | ||||||
| 193 | our %config_type = ( | ||||||
| 194 | check_ => '0|1|warn', | ||||||
| 195 | max_ => '\d+', | ||||||
| 196 | ignore_ => '\S+', | ||||||
| 197 | _default => '0|1', | ||||||
| 198 | ); | ||||||
| 199 | |||||||
| 200 | sub get_config_keys { | ||||||
| 201 | 305 | 0 | 1236 | return keys %config; | |||
| 202 | } | ||||||
| 203 | |||||||
| 204 | sub valid_config_key { | ||||||
| 205 | 0 | 0 | 0 | my ($key) = @_; | |||
| 206 | 0 | 0 | return exists $config{$key}; | ||||
| 207 | } | ||||||
| 208 | |||||||
| 209 | sub get_config_pattern { | ||||||
| 210 | 5188 | 0 | 4322 | my ($key) = @_; | |||
| 211 | 5188 | 3591 | my $pattern; | ||||
| 212 | 5188 | 8013 | for my $prefix (keys %config_type) { | ||||
| 213 | 15358 | 108320 | if ($key =~ /^$prefix/) { | ||||
| 214 | 3662 | 3901 | $pattern = $config_type{$prefix}; | ||||
| 215 | 3662 | 3810 | last; | ||||
| 216 | } | ||||||
| 217 | } | ||||||
| 218 | 5188 | 15648 | return $pattern || $config_type{_default}; | ||||
| 219 | } | ||||||
| 220 | |||||||
| 221 | # Checks for valid config key/value pair. | ||||||
| 222 | # Returns false on success, the expected pattern on failure. | ||||||
| 223 | sub check_config_pair { | ||||||
| 224 | 3 | 0 | 5 | my ($key, $value) = @_; | |||
| 225 | 3 | 4 | my $pattern = get_config_pattern($key); | ||||
| 226 | 3 | 93 | return ($value =~ /^($pattern)$/ ? undef : $pattern); | ||||
| 227 | } | ||||||
| 228 | |||||||
| 229 | # Set %config with pairs from one or more hashrefs. | ||||||
| 230 | # Rightmost hash overrides previous values with same key. | ||||||
| 231 | sub set_config { | ||||||
| 232 | 337 | 0 | 475 | my (@hrefs) = @_; | |||
| 233 | 337 | 438 | for my $href (@hrefs) { | ||||
| 234 | 663 | 1722 | while (my ($key, $val) = each %$href) { | ||||
| 235 | 388 | 1274 | $config{$key} = $val; | ||||
| 236 | } | ||||||
| 237 | } | ||||||
| 238 | 337 | 514 | return; | ||||
| 239 | } | ||||||
| 240 | |||||||
| 241 | # Modified only by sub store_description. | ||||||
| 242 | my $new_store_description; | ||||||
| 243 | |||||||
| 244 | sub store_description { | ||||||
| 245 | 13 | 0 | 18 | my ($set) = @_; | |||
| 246 | 13 | 27 | if (defined $set) { | ||||
| 247 | 11 | 18 | return($new_store_description = $set); | ||||
| 248 | } | ||||||
| 249 | else { | ||||||
| 250 | 2 | 5 | return $new_store_description; | ||||
| 251 | } | ||||||
| 252 | } | ||||||
| 253 | |||||||
| 254 | my $fast_mode; | ||||||
| 255 | sub fast_mode { | ||||||
| 256 | 947 | 0 | 899 | my ($set) = @_; | |||
| 257 | 947 | 1278 | if (defined $set) { | ||||
| 258 | 305 | 360 | return($fast_mode = $set); | ||||
| 259 | } | ||||||
| 260 | else { | ||||||
| 261 | 642 | 1328 | return $fast_mode; | ||||
| 262 | } | ||||||
| 263 | } | ||||||
| 264 | |||||||
| 265 | # Use non-local function exit for efficiency. | ||||||
| 266 | # Perl profiler doesn't work if this is active. | ||||||
| 267 | my $use_nonlocal_exit => 1; | ||||||
| 268 | |||||||
| 269 | #################################################################### | ||||||
| 270 | # Attributes of supported router models | ||||||
| 271 | #################################################################### | ||||||
| 272 | my %router_info = ( | ||||||
| 273 | IOS => { | ||||||
| 274 | routing => 'IOS', | ||||||
| 275 | filter => 'IOS', | ||||||
| 276 | stateless => 1, | ||||||
| 277 | stateless_self => 1, | ||||||
| 278 | stateless_icmp => 1, | ||||||
| 279 | inversed_acl_mask => 1, | ||||||
| 280 | can_vrf => 1, | ||||||
| 281 | can_log_deny => 1, | ||||||
| 282 | log_modifiers => { 'log-input' => ':subst' }, | ||||||
| 283 | has_out_acl => 1, | ||||||
| 284 | need_protect => 1, | ||||||
| 285 | crypto => 'IOS', | ||||||
| 286 | print_interface => 1, | ||||||
| 287 | comment_char => '!', | ||||||
| 288 | extension => { | ||||||
| 289 | EZVPN => { crypto => 'EZVPN' }, | ||||||
| 290 | FW => { stateless => 0 }, | ||||||
| 291 | }, | ||||||
| 292 | }, | ||||||
| 293 | 'NX-OS' => { | ||||||
| 294 | routing => 'NX-OS', | ||||||
| 295 | filter => 'NX-OS', | ||||||
| 296 | stateless => 1, | ||||||
| 297 | stateless_self => 1, | ||||||
| 298 | stateless_icmp => 1, | ||||||
| 299 | can_objectgroup => 1, | ||||||
| 300 | inversed_acl_mask => 1, | ||||||
| 301 | use_prefix => 1, | ||||||
| 302 | can_vrf => 1, | ||||||
| 303 | can_log_deny => 1, | ||||||
| 304 | log_modifiers => {}, | ||||||
| 305 | has_out_acl => 1, | ||||||
| 306 | need_protect => 1, | ||||||
| 307 | print_interface => 1, | ||||||
| 308 | comment_char => '!', | ||||||
| 309 | }, | ||||||
| 310 | 'ACE' => { | ||||||
| 311 | routing => 'IOS', | ||||||
| 312 | filter => 'ACE', | ||||||
| 313 | stateless => 0, | ||||||
| 314 | stateless_self => 0, | ||||||
| 315 | stateless_icmp => 1, | ||||||
| 316 | can_objectgroup => 1, | ||||||
| 317 | inversed_acl_mask => 0, | ||||||
| 318 | use_prefix => 0, | ||||||
| 319 | can_vrf => 0, | ||||||
| 320 | can_log_deny => 0, | ||||||
| 321 | log_modifiers => {}, | ||||||
| 322 | has_vip => 1, | ||||||
| 323 | has_out_acl => 1, | ||||||
| 324 | need_protect => 1, | ||||||
| 325 | print_interface => 1, | ||||||
| 326 | comment_char => '!', | ||||||
| 327 | }, | ||||||
| 328 | PIX => { | ||||||
| 329 | routing => 'PIX', | ||||||
| 330 | filter => 'PIX', | ||||||
| 331 | stateless_icmp => 1, | ||||||
| 332 | can_objectgroup => 1, | ||||||
| 333 | comment_char => '!', | ||||||
| 334 | has_interface_level => 1, | ||||||
| 335 | need_identity_nat => 1, | ||||||
| 336 | no_filter_icmp_code => 1, | ||||||
| 337 | need_acl => 1, | ||||||
| 338 | }, | ||||||
| 339 | |||||||
| 340 | # Like PIX, but without identity NAT. | ||||||
| 341 | ASA => { | ||||||
| 342 | routing => 'PIX', | ||||||
| 343 | filter => 'PIX', | ||||||
| 344 | log_modifiers => { emergencies => 0, | ||||||
| 345 | alerts => 1, | ||||||
| 346 | critical => 2, | ||||||
| 347 | errors => 3, | ||||||
| 348 | warnings => 4, | ||||||
| 349 | notifications => 5, | ||||||
| 350 | informational => 6, | ||||||
| 351 | debugging => 7, | ||||||
| 352 | disable => 'disable', | ||||||
| 353 | }, | ||||||
| 354 | stateless_icmp => 1, | ||||||
| 355 | has_out_acl => 1, | ||||||
| 356 | can_objectgroup => 1, | ||||||
| 357 | can_dyn_crypto => 1, | ||||||
| 358 | crypto => 'ASA', | ||||||
| 359 | no_crypto_filter => 1, | ||||||
| 360 | comment_char => '!', | ||||||
| 361 | has_interface_level => 1, | ||||||
| 362 | no_filter_icmp_code => 1, | ||||||
| 363 | need_acl => 1, | ||||||
| 364 | extension => { | ||||||
| 365 | VPN => { | ||||||
| 366 | crypto => 'ASA_VPN', | ||||||
| 367 | stateless_tunnel => 1, | ||||||
| 368 | do_auth => 1, | ||||||
| 369 | }, | ||||||
| 370 | EZVPN => { crypto => 'ASA_EZVPN' }, | ||||||
| 371 | '8.4' => { v8_4 => 1, }, | ||||||
| 372 | }, | ||||||
| 373 | }, | ||||||
| 374 | Linux => { | ||||||
| 375 | routing => 'iproute', | ||||||
| 376 | filter => 'iptables', | ||||||
| 377 | has_io_acl => 1, | ||||||
| 378 | comment_char => '#', | ||||||
| 379 | can_managed_host => 1, | ||||||
| 380 | }, | ||||||
| 381 | ); | ||||||
| 382 | for my $model (keys %router_info) { | ||||||
| 383 | |||||||
| 384 | # Is changed for model with extension. Used in error messages. | ||||||
| 385 | $router_info{$model}->{name} = $model; | ||||||
| 386 | |||||||
| 387 | # Is left unchanged with extensions. Used in header of generated files. | ||||||
| 388 | $router_info{$model}->{class} = $model; | ||||||
| 389 | } | ||||||
| 390 | |||||||
| 391 | # Use this if src or dst port isn't defined. | ||||||
| 392 | # Don't allocate memory again and again. | ||||||
| 393 | my $aref_tcp_any = [ 1, 65535 ]; | ||||||
| 394 | |||||||
| 395 | # Definition of dynamic routing protocols. | ||||||
| 396 | # Protocols get {up} relation in order_protocols. | ||||||
| 397 | my %routing_info; | ||||||
| 398 | |||||||
| 399 | # Definition of redundancy protocols. | ||||||
| 400 | # Protocols get {up} relation in order_protocols. | ||||||
| 401 | my %xxrp_info; | ||||||
| 402 | |||||||
| 403 | ## no critic (RequireArgUnpacking) | ||||||
| 404 | |||||||
| 405 | # All arguments are 'eq'. | ||||||
| 406 | sub equal { | ||||||
| 407 | 53 | 0 | 108 | return 1 if not @_; | |||
| 408 | 43 | 39 | my $first = shift; | ||||
| 409 | 43 47 | 56 167 | return not grep { $_ ne $first } @_; | ||||
| 410 | } | ||||||
| 411 | |||||||
| 412 | # Unique union of all elements. | ||||||
| 413 | # Preserves original order. | ||||||
| 414 | sub unique { | ||||||
| 415 | 1062 | 0 | 844 | my %seen; | |||
| 416 | 1062 1091 | 1418 4947 | return grep { !$seen{$_}++ } @_; | ||||
| 417 | } | ||||||
| 418 | |||||||
| 419 | sub find_duplicates { | ||||||
| 420 | 67 | 0 | 58 | my %dupl; | |||
| 421 | 67 | 183 | $dupl{$_}++ for @_; | ||||
| 422 | 67 77 | 119 291 | return grep { $dupl{$_} > 1 } keys %dupl; | ||||
| 423 | } | ||||||
| 424 | |||||||
| 425 | sub intersect { | ||||||
| 426 | 3 | 0 | 4 | my ($aref1, $aref2) = @_; | |||
| 427 | 3 3 | 3 9 | my %seen = map { $_ => 1 } @$aref1; | ||||
| 428 | 3 3 | 3 9 | return grep { $seen{$_} } @$aref2; | ||||
| 429 | } | ||||||
| 430 | |||||||
| 431 | sub max { | ||||||
| 432 | 0 | 0 | 0 | my $max = shift(@_); | |||
| 433 | 0 | 0 | for my $el (@_) { | ||||
| 434 | 0 | 0 | $max = $el if $max < $el; | ||||
| 435 | } | ||||||
| 436 | 0 | 0 | return $max; | ||||
| 437 | } | ||||||
| 438 | |||||||
| 439 | # Delete an element from an array reference. | ||||||
| 440 | # Return 1 if found, undef otherwise. | ||||||
| 441 | sub aref_delete { | ||||||
| 442 | 163 | 0 | 154 | my ($aref, $elt) = @_; | |||
| 443 | 163 | 283 | for (my $i = 0 ; $i < @$aref ; $i++) { | ||||
| 444 | 199 | 421 | if ($aref->[$i] eq $elt) { | ||||
| 445 | 163 | 172 | splice @$aref, $i, 1; | ||||
| 446 | |||||||
| 447 | #debug("aref_delete: $elt->{name}"); | ||||||
| 448 | 163 | 292 | return 1; | ||||
| 449 | } | ||||||
| 450 | } | ||||||
| 451 | 0 | 0 | return; | ||||
| 452 | } | ||||||
| 453 | |||||||
| 454 | # Compare two array references element wise. | ||||||
| 455 | sub aref_eq { | ||||||
| 456 | 1390 | 0 | 1186 | my ($a1, $a2) = @_; | |||
| 457 | 1390 | 2474 | return if @$a1 ne @$a2; | ||||
| 458 | 1131 | 1867 | for (my $i = 0 ; $i < @$a1 ; $i++) { | ||||
| 459 | 98 | 244 | return if $a1->[$i] ne $a2->[$i]; | ||||
| 460 | } | ||||||
| 461 | 1109 | 1622 | return 1; | ||||
| 462 | } | ||||||
| 463 | |||||||
| 464 | sub keys_eq { | ||||||
| 465 | 36 | 0 | 40 | my ($href1, $href2) = @_; | |||
| 466 | 36 | 80 | keys %$href1 == keys %$href2 or return; | ||||
| 467 | 22 | 37 | for my $key (keys %$href1) { | ||||
| 468 | 25 | 65 | exists $href2->{$key} or return; | ||||
| 469 | } | ||||||
| 470 | 16 | 42 | return 1; | ||||
| 471 | } | ||||||
| 472 | |||||||
| 473 | my $start_time; | ||||||
| 474 | |||||||
| 475 | sub info { | ||||||
| 476 | 1542 | 0 | 2558 | return if not $config{verbose}; | |||
| 477 | 0 | 0 | print STDERR @_, "\n"; | ||||
| 478 | 0 | 0 | return; | ||||
| 479 | } | ||||||
| 480 | |||||||
| 481 | sub progress { | ||||||
| 482 | 6727 | 0 | 11206 | return if not $config{verbose}; | |||
| 483 | 0 | 0 | if ($config{time_stamps}) { | ||||
| 484 | 0 | 0 | my $diff = time() - $start_time; | ||||
| 485 | 0 | 0 | printf STDERR "%3ds ", $diff; | ||||
| 486 | } | ||||||
| 487 | 0 | 0 | info(@_); | ||||
| 488 | 0 | 0 | return; | ||||
| 489 | } | ||||||
| 490 | |||||||
| 491 | sub warn_msg { | ||||||
| 492 | 72 | 0 | 1492 | print STDERR "Warning: ", @_, "\n"; | |||
| 493 | 72 | 171 | return; | ||||
| 494 | } | ||||||
| 495 | |||||||
| 496 | sub debug { | ||||||
| 497 | 0 | 0 | 0 | return if not $config{verbose}; | |||
| 498 | 0 | 0 | print STDERR @_, "\n"; | ||||
| 499 | 0 | 0 | return; | ||||
| 500 | } | ||||||
| 501 | ## use critic | ||||||
| 502 | |||||||
| 503 | # Name of current input file. | ||||||
| 504 | our $current_file; | ||||||
| 505 | |||||||
| 506 | # Rules and objects read from directories and files with | ||||||
| 507 | # special name 'xxx.private' are marked with attribute {private} = 'xxx'. | ||||||
| 508 | # This variable is used to propagate the value from directories to its | ||||||
| 509 | # files and sub-directories. | ||||||
| 510 | our $private; | ||||||
| 511 | |||||||
| 512 | # Content of current file. | ||||||
| 513 | our $input; | ||||||
| 514 | |||||||
| 515 | # Current line number of input file. | ||||||
| 516 | our $line; | ||||||
| 517 | |||||||
| 518 | sub context { | ||||||
| 519 | 0 | 0 | 0 | my $context; | |||
| 520 | 0 | 0 | if (pos $input == length $input) { | ||||
| 521 | 0 | 0 | $context = 'at EOF'; | ||||
| 522 | } | ||||||
| 523 | else { | ||||||
| 524 | 0 | 0 | my ($pre, $post) = | ||||
| 525 | $input =~ m/([^ \t\n,;={}]*[,;={} \t]*)\G([,;={} \t]*[^ \t\n,;={}]*)/; | ||||||
| 526 | 0 | 0 | $context = qq/near "$pre<--HERE-->$post"/; | ||||
| 527 | } | ||||||
| 528 | 0 | 0 | return qq/ at line $line of $current_file, $context\n/; | ||||
| 529 | } | ||||||
| 530 | |||||||
| 531 | sub at_line { | ||||||
| 532 | 12 | 0 | 299 | return qq/ at line $line of $current_file\n/; | |||
| 533 | } | ||||||
| 534 | |||||||
| 535 | our $error_counter; | ||||||
| 536 | our $abort_immediately; | ||||||
| 537 | |||||||
| 538 | sub check_abort { | ||||||
| 539 | 124 | 0 | 112 | $error_counter++; | |||
| 540 | 124 | 355 | if ($error_counter == $config{max_errors}) { | ||||
| 541 | 0 | 0 | die "Aborted after $error_counter errors\n"; | ||||
| 542 | } | ||||||
| 543 | elsif ($abort_immediately) { | ||||||
| 544 | 0 | 0 | die "Aborted\n"; | ||||
| 545 | } | ||||||
| 546 | } | ||||||
| 547 | |||||||
| 548 | sub abort_on_error { | ||||||
| 549 | 542 | 0 | 1270 | die "Aborted with $error_counter error(s)\n" if $error_counter; | |||
| 550 | 450 | 390 | return; | ||||
| 551 | } | ||||||
| 552 | |||||||
| 553 | sub set_abort_immediately { | ||||||
| 554 | 208 | 0 | 176 | $abort_immediately = 1; | |||
| 555 | 208 | 172 | return; | ||||
| 556 | } | ||||||
| 557 | |||||||
| 558 | sub error_atline { | ||||||
| 559 | 12 | 0 | 19 | my (@args) = @_; | |||
| 560 | 12 | 24 | print STDERR "Error: ", @args, at_line(); | ||||
| 561 | 12 | 23 | check_abort(); | ||||
| 562 | 12 | 16 | return; | ||||
| 563 | } | ||||||
| 564 | |||||||
| 565 | sub err_msg { | ||||||
| 566 | 112 | 0 | 186 | my (@args) = @_; | |||
| 567 | 112 | 2811 | print STDERR "Error: ", @args, "\n"; | ||||
| 568 | 112 | 180 | check_abort(); | ||||
| 569 | 112 | 241 | return; | ||||
| 570 | } | ||||||
| 571 | |||||||
| 572 | sub fatal_err { | ||||||
| 573 | 5 | 0 | 6 | my (@args) = @_; | |||
| 574 | 5 | 55 | print STDERR "Error: ", @args, "\n"; | ||||
| 575 | 5 | 27 | die "Aborted\n"; | ||||
| 576 | } | ||||||
| 577 | |||||||
| 578 | sub syntax_err { | ||||||
| 579 | 0 | 0 | 0 | my (@args) = @_; | |||
| 580 | 0 | 0 | die "Syntax error: ", @args, context(); | ||||
| 581 | } | ||||||
| 582 | |||||||
| 583 | sub internal_err { | ||||||
| 584 | 0 | 0 | 0 | my (@args) = @_; | |||
| 585 | |||||||
| 586 | # Don't show inherited error. | ||||||
| 587 | # Abort immediately, if other errors have already occured. | ||||||
| 588 | 0 | 0 | if ($error_counter) { | ||||
| 589 | 0 | 0 | die "Aborted after $error_counter errors\n"; | ||||
| 590 | } | ||||||
| 591 | 0 | 0 | my (undef, $file, $line) = caller; | ||||
| 592 | 0 | 0 | my $sub = (caller 1)[3]; | ||||
| 593 | 0 | 0 | my $msg = "Internal error in $sub"; | ||||
| 594 | 0 | 0 | $msg .= ": @args" if @args; | ||||
| 595 | |||||||
| 596 | 0 | 0 | die "$msg\n at $file line $line\n"; | ||||
| 597 | } | ||||||
| 598 | |||||||
| 599 | #################################################################### | ||||||
| 600 | # Helper functions for reading configuration | ||||||
| 601 | #################################################################### | ||||||
| 602 | |||||||
| 603 | # $input is used as input buffer, it holds content of current input file. | ||||||
| 604 | # Progressive matching is used. \G is used to match current position. | ||||||
| 605 | sub skip_space_and_comment { | ||||||
| 606 | |||||||
| 607 | # Ignore trailing white space and comments. | ||||||
| 608 | 112983 | 0 | 285320 | while ($input =~ m'\G[ \t]*(?:[#].*)?(?:\n|$)'gc) { | |||
| 609 | 9655 | 22976 | $line++; | ||||
| 610 | } | ||||||
| 611 | |||||||
| 612 | # Ignore leading white space. | ||||||
| 613 | 112983 | 119016 | $input =~ m/\G[ \t]*/gc; | ||||
| 614 | 112983 | 93870 | return; | ||||
| 615 | } | ||||||
| 616 | |||||||
| 617 | # Optimize use of CORE:regcomp. Build regex only once for each token. | ||||||
| 618 | my %token2regex; | ||||||
| 619 | |||||||
| 620 | # Check for a string and skip if available. | ||||||
| 621 | sub check { | ||||||
| 622 | 96427 | 0 | 75156 | my $token = shift; | |||
| 623 | 96427 | 99103 | skip_space_and_comment; | ||||
| 624 | 96427 | 273837 | my $regex = $token2regex{$token} ||= qr/\G$token/; | ||||
| 625 | 96427 | 415506 | return $input =~ /$regex/gc; | ||||
| 626 | } | ||||||
| 627 | |||||||
| 628 | # Skip a string. | ||||||
| 629 | sub skip { | ||||||
| 630 | 19078 | 0 | 16319 | my $token = shift; | |||
| 631 | 19078 | 20448 | return(check $token or syntax_err("Expected '$token'")); | ||||
| 632 | } | ||||||
| 633 | |||||||
| 634 | # Check, if an integer is available. | ||||||
| 635 | sub check_int { | ||||||
| 636 | 1617 | 0 | 1711 | skip_space_and_comment; | |||
| 637 | 1617 | 2860 | if ($input =~ m/\G(\d+)/gc) { | ||||
| 638 | 1591 | 3221 | return $1; | ||||
| 639 | } | ||||||
| 640 | else { | ||||||
| 641 | 26 | 52 | return; | ||||
| 642 | } | ||||||
| 643 | } | ||||||
| 644 | |||||||
| 645 | sub read_int { | ||||||
| 646 | 1272 | 0 | 1420 | my $result = check_int(); | |||
| 647 | 1272 | 2088 | defined $result or syntax_err("Integer expected"); | ||||
| 648 | 1272 | 2144 | return $result; | ||||
| 649 | } | ||||||
| 650 | |||||||
| 651 | # Read IP address. Internally it is stored as an integer. | ||||||
| 652 | sub check_ip { | ||||||
| 653 | 2771 | 0 | 2935 | skip_space_and_comment; | |||
| 654 | 2771 | 8082 | if ($input =~ m/\G(\d+)\.(\d+)\.(\d+)\.(\d+)/gc) { | ||||
| 655 | 2771 | 20983 | if ($1 > 255 or $2 > 255 or $3 > 255 or $4 > 255) { | ||||
| 656 | 0 | 0 | error_atline("Invalid IP address"); | ||||
| 657 | } | ||||||
| 658 | 2771 | 8715 | return unpack 'N', pack 'C4', $1, $2, $3, $4; | ||||
| 659 | } | ||||||
| 660 | else { | ||||||
| 661 | 0 | 0 | return; | ||||
| 662 | } | ||||||
| 663 | } | ||||||
| 664 | |||||||
| 665 | sub read_ip { | ||||||
| 666 | 2771 | 0 | 3446 | my $result = check_ip(); | |||
| 667 | 2771 | 4509 | defined $result or syntax_err("IP address expected"); | ||||
| 668 | 2771 | 3063 | return $result; | ||||
| 669 | } | ||||||
| 670 | |||||||
| 671 | # Read IP address and prefix length. | ||||||
| 672 | # x.x.x.x/n | ||||||
| 673 | sub read_ip_prefix { | ||||||
| 674 | 1232 | 0 | 2341 | my $ip = read_ip; | |||
| 675 | 1232 | 1588 | skip('/'); | ||||
| 676 | 1232 | 1746 | my $mask = prefix2mask(read_int()); | ||||
| 677 | 1232 | 1926 | defined $mask or syntax_err('Invalid prefix'); | ||||
| 678 | 1232 | 1567 | match_ip($ip, $ip, $mask) or error_atline("IP and mask don't match"); | ||||
| 679 | |||||||
| 680 | # Prevent further errors. | ||||||
| 681 | 1232 | 1164 | $ip &= $mask; | ||||
| 682 | 1232 | 1941 | return $ip, $mask; | ||||
| 683 | } | ||||||
| 684 | |||||||
| 685 | sub read_ip_prefix_pair { | ||||||
| 686 | 77 | 0 | 90 | my ($ip, $mask) = read_ip_prefix(); | |||
| 687 | 77 | 130 | return [ $ip, $mask ]; | ||||
| 688 | } | ||||||
| 689 | |||||||
| 690 | sub gen_ip { | ||||||
| 691 | 4500 | 0 | 3802 | my ($byte1, $byte2, $byte3, $byte4) = @_; | |||
| 692 | 4500 | 9510 | return unpack 'N', pack('C4', $byte1, $byte2, $byte3, $byte4); | ||||
| 693 | } | ||||||
| 694 | |||||||
| 695 | # Convert IP address from internal integer representation to | ||||||
| 696 | # readable string. | ||||||
| 697 | sub print_ip { | ||||||
| 698 | 2866 | 0 | 2406 | my $ip = shift; | |||
| 699 | 2866 | 7977 | return sprintf "%vd", pack 'N', $ip; | ||||
| 700 | } | ||||||
| 701 | |||||||
| 702 | # Conversion from netmask to prefix and vice versa. | ||||||
| 703 | { | ||||||
| 704 | |||||||
| 705 | # Initialize private variables of this block. | ||||||
| 706 | my %mask2prefix; | ||||||
| 707 | my %prefix2mask; | ||||||
| 708 | for my $prefix (0 .. 32) { | ||||||
| 709 | my $mask = 2**32 - 2**(32 - $prefix); | ||||||
| 710 | $mask2prefix{$mask} = $prefix; | ||||||
| 711 | $prefix2mask{$prefix} = $mask; | ||||||
| 712 | } | ||||||
| 713 | |||||||
| 714 | # Convert a network mask to a prefix ranging from 0 to 32. | ||||||
| 715 | sub mask2prefix { | ||||||
| 716 | 1752 | 0 | 1526 | my $mask = shift; | |||
| 717 | 1752 | 2602 | return $mask2prefix{$mask}; | ||||
| 718 | } | ||||||
| 719 | |||||||
| 720 | sub prefix2mask { | ||||||
| 721 | 3602 | 0 | 2871 | my $prefix = shift; | |||
| 722 | 3602 | 5124 | return $prefix2mask{$prefix}; | ||||
| 723 | } | ||||||
| 724 | } | ||||||
| 725 | |||||||
| 726 | sub complement_32bit { | ||||||
| 727 | 4555 | 0 | 3553 | my ($ip) = @_; | |||
| 728 | 4555 | 5608 | return ~$ip & 0xffffffff; | ||||
| 729 | } | ||||||
| 730 | |||||||
| 731 | # Check if $ip1 is located inside network $ip/$mask. | ||||||
| 732 | sub match_ip { | ||||||
| 733 | 3585 | 0 | 3712 | my ($ip1, $ip, $mask) = @_; | |||
| 734 | 3585 | 8493 | return ($ip == ($ip1 & $mask)); | ||||
| 735 | } | ||||||
| 736 | |||||||
| 737 | sub read_identifier { | ||||||
| 738 | 1337 | 0 | 1467 | skip_space_and_comment; | |||
| 739 | 1337 | 2995 | if ($input =~ m/(\G[\w-]+)/gc) { | ||||
| 740 | 1337 | 2636 | return $1; | ||||
| 741 | } | ||||||
| 742 | else { | ||||||
| 743 | 0 | 0 | syntax_err("Identifier expected"); | ||||
| 744 | } | ||||||
| 745 | } | ||||||
| 746 | |||||||
| 747 | # Pattrern for attribute "visible": "*" or "name*". | ||||||
| 748 | sub read_owner_pattern { | ||||||
| 749 | 0 | 0 | 0 | skip_space_and_comment; | |||
| 750 | 0 | 0 | if ($input =~ m/ ( \G [\w-]* [*] ) /gcx) { | ||||
| 751 | 0 | 0 | return $1; | ||||
| 752 | } | ||||||
| 753 | else { | ||||||
| 754 | 0 | 0 | syntax_err("Pattern '*' or 'name*' expected"); | ||||
| 755 | } | ||||||
| 756 | } | ||||||
| 757 | |||||||
| 758 | # Used for reading hardware name, model, admins, watchers. | ||||||
| 759 | sub read_name { | ||||||
| 760 | 1751 | 0 | 1969 | skip_space_and_comment; | |||
| 761 | 1751 | 4035 | if ($input =~ m/(\G[^;,\s""'']+)/gc) { | ||||
| 762 | 1751 | 3528 | return $1; | ||||
| 763 | } | ||||||
| 764 | else { | ||||||
| 765 | 0 | 0 | syntax_err("String expected"); | ||||
| 766 | } | ||||||
| 767 | } | ||||||
| 768 | |||||||
| 769 | # Used for reading alias name or radius attributes. | ||||||
| 770 | sub read_string { | ||||||
| 771 | 35 | 0 | 43 | skip_space_and_comment; | |||
| 772 | 35 | 66 | if ($input =~ m/\G([^;,""''\n]+)/gc) { | ||||
| 773 | 35 | 64 | return $1; | ||||
| 774 | } | ||||||
| 775 | else { | ||||||
| 776 | 0 | 0 | syntax_err("String expected"); | ||||
| 777 | } | ||||||
| 778 | } | ||||||
| 779 | |||||||
| 780 | # Object representing 'user'. | ||||||
| 781 | # This is only 'active' while parsing src or dst of the rule of a service. | ||||||
| 782 | my $user_object = { active => 0, refcount => 0, elements => undef }; | ||||||
| 783 | |||||||
| 784 | sub read_union { | ||||||
| 785 | 728 | 0 | 707 | my ($delimiter) = @_; | |||
| 786 | 728 | 564 | my @vals; | ||||
| 787 | 728 | 700 | my $count = $user_object->{refcount}; | ||||
| 788 | 728 | 877 | push @vals, read_intersection(); | ||||
| 789 | 728 | 1360 | my $has_user_ref = $user_object->{refcount} > $count; | ||||
| 790 | 728 | 613 | my $user_ref_error = 0; | ||||
| 791 | 728 | 558 | while (1) { | ||||
| 792 | 745 | 875 | last if check $delimiter; | ||||
| 793 | 17 | 29 | my $comma_seen = check ','; | ||||
| 794 | |||||||
| 795 | # Allow trailing comma. | ||||||
| 796 | 17 | 33 | last if check $delimiter; | ||||
| 797 | |||||||
| 798 | 17 | 36 | $comma_seen or syntax_err("Comma expected in union of values"); | ||||
| 799 | 17 | 25 | $count = $user_object->{refcount}; | ||||
| 800 | 17 | 26 | push @vals, read_intersection(); | ||||
| 801 | 17 | 73 | $user_ref_error ||= | ||||
| 802 | $has_user_ref != ($user_object->{refcount} > $count); | ||||||
| 803 | } | ||||||
| 804 | $user_ref_error | ||||||
| 805 | 728 | 1169 | and error_atline("The sub-expressions of union equally must\n", | ||||
| 806 | " either reference 'user' or must not reference 'user'"); | ||||||
| 807 | 728 | 1232 | return @vals; | ||||
| 808 | } | ||||||
| 809 | |||||||
| 810 | # Check for xxx:xxx | router:xx@xx | network:xx/xx | interface:xx/xx | ||||||
| 811 | sub check_typed_name { | ||||||
| 812 | 5622 | 0 | 5871 | skip_space_and_comment; | |||
| 813 | 5622 | 16418 | $input =~ m/ \G (\w+) : /gcx or return; | ||||
| 814 | 4062 | 6295 | my $type = $1; | ||||
| 815 | 4062 | 3086 | my ($name, $separator); | ||||
| 816 | 4062 | 10730 | if ($input =~ m' \G ( [\w-]+ (?: ( [@/] ) [\w-]+ )? ) 'gcx) { | ||||
| 817 | 4062 | 4723 | $name = $1; | ||||
| 818 | 4062 | 4206 | $separator = $2; | ||||
| 819 | } | ||||||
| 820 | else { | ||||||
| 821 | 0 | 0 | syntax_err("Invalid token"); | ||||
| 822 | } | ||||||
| 823 | |||||||
| 824 | 4062 | 5729 | if ($separator) { | ||||
| 825 | 46 | 135 | if ($type eq 'router') { | ||||
| 826 | 6 | 12 | $separator eq '@' or syntax_err("Invalid token"); | ||||
| 827 | } | ||||||
| 828 | elsif ($type eq 'network' or $type eq 'interface') { | ||||||
| 829 | 40 | 63 | $separator eq '/' or syntax_err("Invalid token"); | ||||
| 830 | } | ||||||
| 831 | else { | ||||||
| 832 | 0 | 0 | syntax_err("Invalid token"); | ||||
| 833 | } | ||||||
| 834 | } | ||||||
| 835 | 4062 | 11224 | return [ $type, $name ]; | ||||
| 836 | } | ||||||
| 837 | |||||||
| 838 | sub read_typed_name { | ||||||
| 839 | 1727 | 0 | 1916 | return check_typed_name || syntax_err("Typed name expected"); | |||
| 840 | } | ||||||
| 841 | |||||||
| 842 | { | ||||||
| 843 | |||||||
| 844 | # user@domain or @domain | ||||||
| 845 | my $domain_regex = qr/(?:[\w-]+\.)+[\w-]+/; | ||||||
| 846 | my $user_regex = qr/[\w-]+(?:\.[\w-]+)*/; | ||||||
| 847 | my $user_id_regex = qr/$user_regex[@]$domain_regex/; | ||||||
| 848 | my $id_regex = qr/$user_id_regex|[@]?$domain_regex/; | ||||||
| 849 | my $hostname_regex = qr/(?: id:$id_regex | [\w-]+ )/x; | ||||||
| 850 | my $network_regex = qr/(?: [\w-]+ (?: \/ [\w-]+ )? )/x; | ||||||
| 851 | |||||||
| 852 | # Check for xxx:xxx or xxx:[xxx:xxx, ...] | ||||||
| 853 | # or interface:xxx.xxx | ||||||
| 854 | # or interface:xxx.xxx.xxx | ||||||
| 855 | # or interface:xxx.[xxx] | ||||||
| 856 | # or interface:r@v. ... | ||||||
| 857 | # or interface:....xxx/ppp... | ||||||
| 858 | # or interface:[xxx:xxx, ...].[xxx] | ||||||
| 859 | # or interface:[managed & xxx:xxx, ...].[xxx] | ||||||
| 860 | # or host:[managed & xxx:xxx, ...] | ||||||
| 861 | # or any:[ ip = n.n.n.n/len & xxx:xxx, ...] | ||||||
| 862 | # or network:xxx/ppp | ||||||
| 863 | # or host:id:user@domain.network | ||||||
| 864 | # or host:id:[@]domain.network | ||||||
| 865 | # | ||||||
| 866 | sub read_extended_name { | ||||||
| 867 | |||||||
| 868 | 1259 | 0 | 1422 | if (check 'user') { | |||
| 869 | |||||||
| 870 | # Global variable for linking occurrences of 'user'. | ||||||
| 871 | 322 | 609 | $user_object->{active} | ||||
| 872 | or syntax_err("Unexpected reference to 'user'"); | ||||||
| 873 | 322 | 296 | $user_object->{refcount}++; | ||||
| 874 | 322 | 887 | return [ 'user', $user_object ]; | ||||
| 875 | } | ||||||
| 876 | 937 | 3482 | $input =~ m/\G([\w-]+):/gc or syntax_err("Type expected"); | ||||
| 877 | 937 | 1358 | my $type = $1; | ||||
| 878 | 937 | 1026 | my $interface = $type eq 'interface'; | ||||
| 879 | 937 | 729 | my $name; | ||||
| 880 | my $ext; | ||||||
| 881 | 937 | 3600 | if ($input =~ m/ \G \[ /gcox) { | ||||
| 882 | 106 | 578 | if (($interface || $type eq 'host') && check('managed')) { | ||||
| 883 | 4 | 5 | $ext = 1; | ||||
| 884 | 4 | 5 | skip '&'; | ||||
| 885 | } | ||||||
| 886 | elsif ($type eq 'any' && check('ip')) { | ||||||
| 887 | 44 | 61 | skip '='; | ||||
| 888 | 44 | 70 | $ext = read_ip_prefix_pair(); | ||||
| 889 | 44 | 55 | skip '&'; | ||||
| 890 | } | ||||||
| 891 | 106 | 200 | $name = [ read_union(']') ]; | ||||
| 892 | } | ||||||
| 893 | elsif ($type eq 'host') { | ||||||
| 894 | 101 | 5057 | $input =~ m/ \G ( $hostname_regex ) /gcox | ||||
| 895 | or syntax_err("Name or ID-name expected"); | ||||||
| 896 | 101 | 415 | $name = $1; | ||||
| 897 | } | ||||||
| 898 | elsif ($type eq 'network') { | ||||||
| 899 | 505 | 11239 | $input =~ m/ \G ( $network_regex ) /gcox | ||||
| 900 | or syntax_err("Name or bridged name expected"); | ||||||
| 901 | 505 | 1165 | $name = $1; | ||||
| 902 | } | ||||||
| 903 | elsif ($interface && $input =~ m/ \G ( [\w-]+ (?: \@ [\w-]+ ) ) /gcx | ||||||
| 904 | || $input =~ m/ \G ( [\w-]+ ) /gcx) | ||||||
| 905 | { | ||||||
| 906 | 225 | 336 | $name = $1; | ||||
| 907 | } | ||||||
| 908 | else { | ||||||
| 909 | 0 | 0 | syntax_err("Identifier or '[' expected"); | ||||
| 910 | } | ||||||
| 911 | 937 | 1517 | if ($interface) { | ||||
| 912 | 196 | 423 | $input =~ m/ \G \. /gcox or syntax_err("Expected '.'"); | ||||
| 913 | 196 | 294 | if ($input =~ m/ \G \[ /gcox) { | ||||
| 914 | 31 | 44 | my $selector = read_identifier; | ||||
| 915 | 31 | 109 | $selector =~ /^(auto|all)$/ or syntax_err("Expected [auto|all]"); | ||||
| 916 | 31 | 52 | $ext = [ $selector, $ext ]; | ||||
| 917 | 31 | 43 | skip '\]'; | ||||
| 918 | } | ||||||
| 919 | else { | ||||||
| 920 | 165 | 244 | $ext and syntax_err("Keyword 'managed' not allowed"); | ||||
| 921 | 165 | 5973 | $input =~ m/ \G ( $network_regex ) /gcox | ||||
| 922 | or syntax_err("Name or bridged name expected"); | ||||||
| 923 | 165 | 336 | $ext = $1; | ||||
| 924 | |||||||
| 925 | # ID of secondary interface. | ||||||
| 926 | 165 | 341 | if ($input =~ m/ \G \. /gcox) { | ||||
| 927 | 16 | 23 | $ext .= '.' . read_identifier; | ||||
| 928 | } | ||||||
| 929 | } | ||||||
| 930 | } | ||||||
| 931 | 937 | 3059 | return $ext ? [ $type, $name, $ext ] : [ $type, $name ]; | ||||
| 932 | } | ||||||
| 933 | |||||||
| 934 | # user@domain | ||||||
| 935 | sub read_user_id { | ||||||
| 936 | 9 | 0 | 14 | skip_space_and_comment; | |||
| 937 | 9 | 377 | if ($input =~ m/\G($user_id_regex)/gco) { | ||||
| 938 | 9 | 20 | return $1; | ||||
| 939 | } | ||||||
| 940 | else { | ||||||
| 941 | 0 | 0 | syntax_err("Id expected ('user\@domain' or 'user')"); | ||||
| 942 | } | ||||||
| 943 | } | ||||||
| 944 | |||||||
| 945 | # host:xxx or host:id:user@domain or host:id:[@]domain | ||||||
| 946 | sub check_hostname { | ||||||
| 947 | 325 | 0 | 410 | skip_space_and_comment; | |||
| 948 | 325 | 700 | if ($input =~ m/\G host:/gcx) { | ||||
| 949 | 201 | 13412 | if ($input =~ m/\G($hostname_regex)/gco) { | ||||
| 950 | 201 | 608 | return $1; | ||||
| 951 | } | ||||||
| 952 | else { | ||||||
| 953 | 0 | 0 | syntax_err('Hostname expected'); | ||||
| 954 | } | ||||||
| 955 | } | ||||||
| 956 | else { | ||||||
| 957 | 124 | 236 | return; | ||||
| 958 | } | ||||||
| 959 | } | ||||||
| 960 | } | ||||||
| 961 | |||||||
| 962 | sub read_complement { | ||||||
| 963 | 1259 | 0 | 1405 | if (check '!') { | |||
| 964 | 7 | 12 | return [ '!', read_extended_name() ]; | ||||
| 965 | } | ||||||
| 966 | else { | ||||||
| 967 | 1252 | 1681 | return read_extended_name(); | ||||
| 968 | } | ||||||
| 969 | } | ||||||
| 970 | |||||||
| 971 | sub read_intersection { | ||||||
| 972 | 1251 | 0 | 1492 | my @result = read_complement(); | |||
| 973 | 1251 | 1969 | while (check '&') { | ||||
| 974 | 8 | 16 | push @result, read_complement(); | ||||
| 975 | } | ||||||
| 976 | 1251 | 1883 | if (@result == 1) { | ||||
| 977 | 1243 | 1816 | return $result[0]; | ||||
| 978 | } | ||||||
| 979 | else { | ||||||
| 980 | 8 | 20 | return [ '&', \@result ]; | ||||
| 981 | } | ||||||
| 982 | } | ||||||
| 983 | |||||||
| 984 | # Setup standard time units with different names and plural forms. | ||||||
| 985 | my %timeunits = (sec => 1, min => 60, hour => 3600, day => 86400,); | ||||||
| 986 | $timeunits{second} = $timeunits{sec}; | ||||||
| 987 | $timeunits{minute} = $timeunits{min}; | ||||||
| 988 | for my $key (keys %timeunits) { | ||||||
| 989 | $timeunits{"${key}s"} = $timeunits{$key}; | ||||||
| 990 | } | ||||||
| 991 | |||||||
| 992 | # Read time value in different units, return seconds. | ||||||
| 993 | sub read_time_val { | ||||||
| 994 | 40 | 0 | 49 | my $int = read_int(); | |||
| 995 | 40 | 59 | my $unit = read_identifier(); | ||||
| 996 | 40 | 82 | my $factor = $timeunits{$unit} or syntax_err("Invalid time unit"); | ||||
| 997 | 40 | 78 | return $int * $factor; | ||||
| 998 | } | ||||||
| 999 | |||||||
| 1000 | sub add_description { | ||||||
| 1001 | 3756 | 0 | 3403 | my ($obj) = @_; | |||
| 1002 | 3756 | 4156 | check 'description' or return; | ||||
| 1003 | 2 | 4 | skip '='; | ||||
| 1004 | |||||||
| 1005 | # Read up to end of line, but ignore ';' at EOL. | ||||||
| 1006 | # We must use '$' here to match EOL, | ||||||
| 1007 | # otherwise $line would be out of sync. | ||||||
| 1008 | 2 | 22 | $input =~ m/\G[ \t]*(.*?)[ \t]*;?[ \t]*$/gcm; | ||||
| 1009 | 2 | 4 | if (store_description()) { | ||||
| 1010 | 0 | 0 | $obj->{description} = $1; | ||||
| 1011 | } | ||||||
| 1012 | 2 | 2 | return; | ||||
| 1013 | } | ||||||
| 1014 | |||||||
| 1015 | # Check if one of the keywords 'permit' or 'deny' is available. | ||||||
| 1016 | sub check_permit_deny { | ||||||
| 1017 | 311 | 0 | 379 | skip_space_and_comment(); | |||
| 1018 | 311 | 798 | if ($input =~ m/\G(permit|deny)/gc) { | ||||
| 1019 | 311 | 972 | return $1; | ||||
| 1020 | } | ||||||
| 1021 | else { | ||||||
| 1022 | 0 | 0 | return; | ||||
| 1023 | } | ||||||
| 1024 | } | ||||||
| 1025 | |||||||
| 1026 | sub check_nat_name { | ||||||
| 1027 | 136 | 0 | 160 | skip_space_and_comment; | |||
| 1028 | 136 | 420 | if ($input =~ m/\G nat:([\w-]+)/gcx) { | ||||
| 1029 | 136 | 367 | return $1; | ||||
| 1030 | } | ||||||
| 1031 | else { | ||||||
| 1032 | 0 | 0 | return; | ||||
| 1033 | } | ||||||
| 1034 | } | ||||||
| 1035 | sub split_typed_name { | ||||||
| 1036 | 181 | 0 | 212 | my ($name) = @_; | |||
| 1037 | |||||||
| 1038 | # Split at first colon; the name may contain further colons. | ||||||
| 1039 | 181 | 595 | return split /[:]/, $name, 2; | ||||
| 1040 | } | ||||||
| 1041 | |||||||
| 1042 | sub check_flag { | ||||||
| 1043 | 18003 | 0 | 14602 | my $token = shift; | |||
| 1044 | 18003 | 18570 | if (check $token) { | ||||
| 1045 | 237 | 375 | skip(';'); | ||||
| 1046 | 237 | 468 | return 1; | ||||
| 1047 | } | ||||||
| 1048 | else { | ||||||
| 1049 | 17766 | 33187 | return; | ||||
| 1050 | } | ||||||
| 1051 | } | ||||||
| 1052 | |||||||
| 1053 | sub check_assign { | ||||||
| 1054 | 14291 | 0 | 13344 | my ($token, $fun) = @_; | |||
| 1055 | 14291 | 14942 | if (check($token)) { | ||||
| 1056 | 2877 | 3660 | skip '='; | ||||
| 1057 | 2877 | 4352 | if (wantarray) { | ||||
| 1058 | 1155 | 1402 | my @val = &$fun; | ||||
| 1059 | 1155 | 1403 | skip(';'); | ||||
| 1060 | 1155 | 3079 | return @val; | ||||
| 1061 | } | ||||||
| 1062 | else { | ||||||
| 1063 | 1722 | 1997 | my $val = &$fun; | ||||
| 1064 | 1722 | 2354 | skip(';'); | ||||
| 1065 | 1722 | 4110 | return $val; | ||||
| 1066 | } | ||||||
| 1067 | } | ||||||
| 1068 | 11414 | 27539 | return; | ||||
| 1069 | } | ||||||
| 1070 | |||||||
| 1071 | sub read_list { | ||||||
| 1072 | 2652 | 0 | 2350 | my ($fun) = @_; | |||
| 1073 | 2652 | 2063 | my @vals; | ||||
| 1074 | 2652 | 2037 | while (1) { | ||||
| 1075 | 2956 | 3446 | push @vals, &$fun; | ||||
| 1076 | 2956 | 3793 | last if check(';'); | ||||
| 1077 | 331 | 445 | my $comma_seen = check ','; | ||||
| 1078 | |||||||
| 1079 | # Allow trailing comma. | ||||||
| 1080 | 331 | 466 | last if check(';'); | ||||
| 1081 | |||||||
| 1082 | 304 | 510 | $comma_seen or syntax_err("Comma expected in list of values"); | ||||
| 1083 | } | ||||||
| 1084 | 2652 | 7212 | return @vals; | ||||
| 1085 | } | ||||||
| 1086 | |||||||
| 1087 | sub read_list_or_null { | ||||||
| 1088 | 11 | 0 | 18 | my ($fun) = @_; | |||
| 1089 | 11 | 14 | return () if check(';'); | ||||
| 1090 | 11 | 21 | return read_list($fun); | ||||
| 1091 | } | ||||||
| 1092 | |||||||
| 1093 | sub read_assign_list { | ||||||
| 1094 | 311 | 0 | 695 | my ($token, $fun) = @_; | |||
| 1095 | 311 | 377 | skip $token; | ||||
| 1096 | 311 | 441 | skip '='; | ||||
| 1097 | 311 | 475 | return read_list($fun); | ||||
| 1098 | } | ||||||
| 1099 | |||||||
| 1100 | sub check_assign_list { | ||||||
| 1101 | 11622 | 0 | 10987 | my ($token, $fun) = @_; | |||
| 1102 | 11622 | 12372 | if (check $token) { | ||||
| 1103 | 2027 | 2536 | skip '='; | ||||
| 1104 | 2027 | 3033 | return &read_list($fun); | ||||
| 1105 | } | ||||||
| 1106 | 9595 | 24169 | return (); | ||||
| 1107 | } | ||||||
| 1108 | |||||||
| 1109 | sub check_assign_pair { | ||||||
| 1110 | 104 | 0 | 121 | my ($token, $delimiter, $fun) = @_; | |||
| 1111 | 104 | 127 | if (check $token) { | ||||
| 1112 | 22 | 32 | skip '='; | ||||
| 1113 | 22 | 32 | my $v1 = &$fun; | ||||
| 1114 | 22 | 31 | skip $delimiter; | ||||
| 1115 | 22 | 26 | my $v2 = &$fun; | ||||
| 1116 | 22 | 33 | skip(';'); | ||||
| 1117 | 22 | 60 | return $v1, $v2; | ||||
| 1118 | } | ||||||
| 1119 | 82 | 204 | return (); | ||||
| 1120 | } | ||||||
| 1121 | |||||||
| 1122 | #################################################################### | ||||||
| 1123 | # Creation of typed structures | ||||||
| 1124 | # Currently we don't use OO features; | ||||||
| 1125 | # We use 'bless' only to give each structure a distinct type. | ||||||
| 1126 | #################################################################### | ||||||
| 1127 | |||||||
| 1128 | # A hash, describing, which parts are read fom JSON. | ||||||
| 1129 | # Possible keys: | ||||||
| 1130 | # - watchers | ||||||
| 1131 | my $from_json; | ||||||
| 1132 | |||||||
| 1133 | # Create a new structure of given type; | ||||||
| 1134 | # initialize it with key / value pairs. | ||||||
| 1135 | sub new { | ||||||
| 1136 | 8253 | 0 | 13026 | my ($type, @pairs) = @_; | |||
| 1137 | 8253 | 13802 | my $self = {@pairs}; | ||||
| 1138 | 8253 | 24129 | return bless $self, $type; | ||||
| 1139 | } | ||||||
| 1140 | |||||||
| 1141 | sub add_attribute { | ||||||
| 1142 | 6180 | 0 | 6494 | my ($obj, $key, $value) = @_; | |||
| 1143 | 6180 | 10145 | defined $obj->{$key} and error_atline("Duplicate attribute '$key'"); | ||||
| 1144 | 6180 | 7232 | $obj->{$key} = $value; | ||||
| 1145 | 6180 | 8365 | return; | ||||
| 1146 | } | ||||||
| 1147 | |||||||
| 1148 | our %hosts; | ||||||
| 1149 | |||||||
| 1150 | sub check_radius_attributes { | ||||||
| 1151 | 1889 | 0 | 1857 | my $result = {}; | |||
| 1152 | 1889 | 2257 | check 'radius_attributes' or return; | ||||
| 1153 | 23 | 31 | skip '='; | ||||
| 1154 | 23 | 32 | skip '\{'; | ||||
| 1155 | 23 | 24 | while (1) { | ||||
| 1156 | 55 | 61 | last if check '\}'; | ||||
| 1157 | 32 | 44 | my $key = read_identifier(); | ||||
| 1158 | 32 | 45 | my $val = check('=') ? read_string : undef; | ||||
| 1159 | 32 | 44 | skip ';'; | ||||
| 1160 | 32 | 44 | add_attribute($result, $key => $val); | ||||
| 1161 | } | ||||||
| 1162 | 23 | 47 | return $result; | ||||
| 1163 | } | ||||||
| 1164 | |||||||
| 1165 | sub check_routing { | ||||||
| 1166 | 1696 | 0 | 2316 | my $protocol = check_assign('routing', \&read_identifier) or return; | |||
| 1167 | 141 | 352 | my $routing = $routing_info{$protocol} | ||||
| 1168 | or error_atline('Unknown routing protocol'); | ||||||
| 1169 | 141 | 253 | return $routing; | ||||
| 1170 | } | ||||||
| 1171 | |||||||
| 1172 | sub check_managed { | ||||||
| 1173 | 2716 | 0 | 2996 | check('managed') or return; | |||
| 1174 | 473 | 458 | my $managed; | ||||
| 1175 | 473 | 589 | if (check ';') { | ||||
| 1176 | 416 | 455 | $managed = 'standard'; | ||||
| 1177 | } | ||||||
| 1178 | elsif (check '=') { | ||||||
| 1179 | 57 | 88 | my $value = read_identifier; | ||||
| 1180 | 57 | 188 | if ($value =~ /^(?:secondary|standard|full|primary| | ||||
| 1181 | local|local_secondary|routing_only)$/x) | ||||||
| 1182 | { | ||||||
| 1183 | 57 | 62 | $managed = $value; | ||||
| 1184 | } | ||||||
| 1185 | else { | ||||||
| 1186 | 0 | 0 | error_atline("Expected value:", | ||||
| 1187 | " secondary|standard|full|primary", | ||||||
| 1188 | "|local|local_secondary|routing_only"); | ||||||
| 1189 | } | ||||||
| 1190 | 57 | 69 | check ';'; | ||||
| 1191 | } | ||||||
| 1192 | else { | ||||||
| 1193 | 0 | 0 | syntax_err("Expected ';' or '='"); | ||||
| 1194 | } | ||||||
| 1195 | 473 | 888 | return $managed; | ||||
| 1196 | } | ||||||
| 1197 | |||||||
| 1198 | sub check_model { | ||||||
| 1199 | 2217 | 0 | 3076 | my ($model, @attributes) = check_assign_list('model', \&read_name) | |||
| 1200 | or return; | ||||||
| 1201 | 485 | 772 | my $info = $router_info{$model}; | ||||
| 1202 | 485 | 934 | if (not $info) { | ||||
| 1203 | 1 | 2 | error_atline("Unknown router model"); | ||||
| 1204 | |||||||
| 1205 | # Prevent further errors. | ||||||
| 1206 | 1 | 4 | return { name => $model };; | ||||
| 1207 | } | ||||||
| 1208 | 484 | 1027 | my $extension_info = $info->{extension} || {}; | ||||
| 1209 | |||||||
| 1210 | 125 | 147 | my @ext_list = map { | ||||
| 1211 | 484 | 568 | my $ext = $extension_info->{$_}; | ||||
| 1212 | 125 | 185 | $ext or error_atline("Unknown extension $_"); | ||||
| 1213 | 125 | 453 | $ext ? %$ext : (); | ||||
| 1214 | } @attributes; | ||||||
| 1215 | 484 | 997 | if (@ext_list) { | ||||
| 1216 | 123 | 1051 | $info = { %$info, @ext_list }; | ||||
| 1217 | 123 | 272 | delete $info->{extension}; | ||||
| 1218 | 123 | 322 | $info->{name} = join(', ', $model, sort @attributes); | ||||
| 1219 | } | ||||||
| 1220 | 484 | 1049 | return $info; | ||||
| 1221 | } | ||||||
| 1222 | |||||||
| 1223 | my @managed_routers; | ||||||
| 1224 | my @router_fragments; | ||||||
| 1225 | |||||||
| 1226 | # Managed host is stored internally as an interface. | ||||||
| 1227 | # The interface gets an artificial router. | ||||||
| 1228 | # Both, router and interface get name "host:xx". | ||||||
| 1229 | sub host_as_interface { | ||||||
| 1230 | 20 | 0 | 22 | my ($host) = @_; | |||
| 1231 | 20 | 22 | my $name = $host->{name}; | ||||
| 1232 | 20 | 25 | my $model = delete $host->{model}; | ||||
| 1233 | 20 | 24 | my $hw_name = delete $host->{hardware}; | ||||
| 1234 | 20 | 48 | if (!$model) { | ||||
| 1235 | 1 | 3 | err_msg("Missing 'model' for managed $host->{name}"); | ||||
| 1236 | |||||||
| 1237 | # Prevent further errors. | ||||||
| 1238 | 1 | 2 | $model = $host->{model} = { name => 'unknown' }; | ||||
| 1239 | } | ||||||
| 1240 | elsif (!$model->{can_managed_host}) { | ||||||
| 1241 | 0 | 0 | err_msg("Must not use model $model->{name} at managed $name"); | ||||
| 1242 | } | ||||||
| 1243 | 20 | 33 | if (!$hw_name) { | ||||
| 1244 | 0 | 0 | err_msg("Missing 'hardware' for $name"); | ||||
| 1245 | } | ||||||
| 1246 | |||||||
| 1247 | # Use device_name with "host:.." prefix to prevent name clash with | ||||||
| 1248 | # real routers. | ||||||
| 1249 | 20 | 27 | my $device_name = | ||||
| 1250 | $host->{server_name} ? "host:$host->{server_name}" : $name; | ||||||
| 1251 | 20 | 27 | my $router = new('Router', name => $name, device_name => $device_name); | ||||
| 1252 | 20 | 31 | $router->{managed} = delete $host->{managed}; | ||||
| 1253 | 20 | 21 | $router->{model} = $model; | ||||
| 1254 | 20 | 35 | my $interface = new('Interface', %$host); | ||||
| 1255 | 20 | 22 | $interface->{router} = $router; | ||||
| 1256 | 20 | 43 | my $hardware = { name => $hw_name, interfaces => [ $interface ] }; | ||||
| 1257 | 20 | 22 | $interface->{hardware} = $hardware; | ||||
| 1258 | 20 | 23 | $interface->{routing} = $routing_info{manual}; | ||||
| 1259 | 20 | 19 | $interface->{is_managed_host} = 1; | ||||
| 1260 | 20 | 26 | $router->{interfaces} = [ $interface ]; | ||||
| 1261 | 20 | 23 | $router->{hardware} = [ $hardware ]; | ||||
| 1262 | |||||||
| 1263 | # Don't add to %routers | ||||||
| 1264 | # - Name lookup isn't needed. | ||||||
| 1265 | # - Linking with network isn't needed. | ||||||
| 1266 | 20 | 20 | push @managed_routers, $router; | ||||
| 1267 | 20 | 81 | return $interface; | ||||
| 1268 | } | ||||||
| 1269 | |||||||
| 1270 | sub read_host { | ||||||
| 1271 | 201 | 0 | 246 | my ($name, $network_name) = @_; | |||
| 1272 | 201 | 265 | my $host = new('Host'); | ||||
| 1273 | 201 | 343 | $host->{private} = $private if $private; | ||||
| 1274 | 201 | 502 | if (my ($id) = ($name =~ /^host:id:(.*)$/)) { | ||||
| 1275 | |||||||
| 1276 | # Make ID unique by appending name of enclosing network. | ||||||
| 1277 | 26 | 44 | $name = "$name.$network_name"; | ||||
| 1278 | 26 | 55 | $host->{id} = $id; | ||||
| 1279 | } | ||||||
| 1280 | 201 | 312 | $host->{name} = $name; | ||||
| 1281 | 201 | 261 | skip '='; | ||||
| 1282 | 201 | 293 | skip '\{'; | ||||
| 1283 | 201 | 312 | add_description($host); | ||||
| 1284 | 201 | 208 | while (1) { | ||||
| 1285 | 483 | 585 | last if check '\}'; | ||||
| 1286 | 282 | 511 | if (my $ip = check_assign 'ip', \&read_ip) { | ||||
| 1287 | 178 | 1345 | add_attribute($host, ip => $ip); | ||||
| 1288 | } | ||||||
| 1289 | elsif (my ($ip1, $ip2) = check_assign_pair('range', '-', \&read_ip)) { | ||||||
| 1290 | 22 | 36 | $ip1 <= $ip2 or error_atline("Invalid IP range"); | ||||
| 1291 | 22 | 47 | add_attribute($host, range => [ $ip1, $ip2 ]); | ||||
| 1292 | } | ||||||
| 1293 | |||||||
| 1294 | # Currently, only simple 'managed' attribute, | ||||||
| 1295 | # because 'secondary' and 'local' isn't supported by Linux. | ||||||
| 1296 | elsif (my $managed = check_managed()) { | ||||||
| 1297 | 20 | 33 | $managed eq 'standard' | ||||
| 1298 | or error_atline("Only 'managed=standard' is supported"); | ||||||
| 1299 | 20 | 28 | add_attribute($host, managed => $managed); | ||||
| 1300 | } | ||||||
| 1301 | elsif (my $model = check_model()) { | ||||||
| 1302 | 20 | 30 | $host->{model} and error_atline("Duplicate attribute 'model'"); | ||||
| 1303 | 20 | 25 | add_attribute($host, model => $model); | ||||
| 1304 | } | ||||||
| 1305 | elsif (my $hardware = check_assign('hardware', \&read_name)) { | ||||||
| 1306 | 21 | 30 | add_attribute($host, hardware => $hardware); | ||||
| 1307 | } | ||||||
| 1308 | elsif (my $server_name = check_assign('server_name', \&read_name)) { | ||||||
| 1309 | 2 | 3 | add_attribute($host, server_name => $server_name); | ||||
| 1310 | } | ||||||
| 1311 | elsif (my $owner = check_assign 'owner', \&read_identifier) { | ||||||
| 1312 | 7 | 12 | add_attribute($host, owner => $owner); | ||||
| 1313 | } | ||||||
| 1314 | elsif (my $radius_attributes = check_radius_attributes) { | ||||||
| 1315 | 9 | 15 | add_attribute($host, radius_attributes => $radius_attributes); | ||||
| 1316 | } | ||||||
| 1317 | elsif (my $pair = check_typed_name) { | ||||||
| 1318 | 3 | 5 | my ($type, $name) = @$pair; | ||||
| 1319 | 3 | 6 | if ($type eq 'nat') { | ||||
| 1320 | 3 | 5 | skip '='; | ||||
| 1321 | 3 | 62 | skip '\{'; | ||||
| 1322 | 3 | 6 | skip 'ip'; | ||||
| 1323 | 3 | 6 | skip '='; | ||||
| 1324 | 3 | 5 | my $nat_ip = read_ip; | ||||
| 1325 | 3 | 7 | skip ';'; | ||||
| 1326 | 3 | 6 | skip '\}'; | ||||
| 1327 | 3 | 10 | $host->{nat}->{$name} | ||||
| 1328 | and error_atline("Duplicate NAT definition"); | ||||||
| 1329 | 3 | 9 | $host->{nat}->{$name} = $nat_ip; | ||||
| 1330 | } | ||||||
| 1331 | else { | ||||||
| 1332 | 0 | 0 | syntax_err("Expected NAT definition"); | ||||
| 1333 | } | ||||||
| 1334 | } | ||||||
| 1335 | else { | ||||||
| 1336 | 0 | 0 | syntax_err("Unexpected attribute"); | ||||
| 1337 | } | ||||||
| 1338 | } | ||||||
| 1339 | 201 | 934 | $host->{ip} xor $host->{range} | ||||
| 1340 | or error_atline("Exactly one of attributes 'ip' and 'range' is needed"); | ||||||
| 1341 | |||||||
| 1342 | 201 | 344 | if ($host->{managed}) { | ||||
| 1343 | 20 | 71 | my %ok = ( name => 1, ip => 1, nat => 1, file => 1, private => 1, | ||||
| 1344 | managed => 1, model => 1, hardware => 1, server_name => 1); | ||||||
| 1345 | 20 | 76 | for my $key (sort keys %$host) { | ||||
| 1346 | 101 | 160 | next if $ok{$key}; | ||||
| 1347 | 1 | 5 | error_atline("Managed $host->{name} must not have attribute '$key'"); | ||||
| 1348 | } | ||||||
| 1349 | 20 | 45 | $host->{ip} ||= 'short'; | ||||
| 1350 | 20 | 28 | return host_as_interface($host); | ||||
| 1351 | } | ||||||
| 1352 | 181 | 284 | if ($host->{id}) { | ||||
| 1353 | 26 | 65 | $host->{radius_attributes} ||= {}; | ||||
| 1354 | } | ||||||
| 1355 | else { | ||||||
| 1356 | 155 | 278 | $host->{radius_attributes} | ||||
| 1357 | and error_atline("Attribute 'radius_attributes' is not allowed", | ||||||
| 1358 | " for $name"); | ||||||
| 1359 | } | ||||||
| 1360 | 181 | 303 | if ($host->{nat}) { | ||||
| 1361 | 2 | 4 | if ($host->{range}) { | ||||
| 1362 | |||||||
| 1363 | # Before changing this, | ||||||
| 1364 | # - look at print_pix_static, | ||||||
| 1365 | # - add consistency tests in convert_hosts. | ||||||
| 1366 | 0 | 0 | error_atline("No NAT supported for host with 'range'"); | ||||
| 1367 | } | ||||||
| 1368 | } | ||||||
| 1369 | 181 | 242 | return $host; | ||||
| 1370 | } | ||||||
| 1371 | |||||||
| 1372 | sub read_nat { | ||||||
| 1373 | 136 | 0 | 151 | my $name = shift; | |||
| 1374 | |||||||
| 1375 | # Currently this needs not to be blessed. | ||||||
| 1376 | 136 | 214 | my $nat = { name => $name }; | ||||
| 1377 | 136 | 435 | (my $nat_tag = $name) =~ s/^nat://; | ||||
| 1378 | 136 | 211 | skip '='; | ||||
| 1379 | 136 | 192 | skip '\{'; | ||||
| 1380 | 136 | 129 | while (1) { | ||||
| 1381 | 312 | 382 | last if check '\}'; | ||||
| 1382 | 176 | 293 | if (my ($ip, $mask) = check_assign 'ip', \&read_ip_prefix) { | ||||
| 1383 | 90 | 134 | add_attribute($nat, ip => $ip); | ||||
| 1384 | 90 | 109 | add_attribute($nat, mask => $mask); | ||||
| 1385 | } | ||||||
| 1386 | elsif (check_flag 'hidden') { | ||||||
| 1387 | 37 | 60 | $nat->{hidden} = 1; | ||||
| 1388 | } | ||||||
| 1389 | elsif (check_flag 'identity') { | ||||||
| 1390 | 9 | 15 | $nat->{identity} = 1; | ||||
| 1391 | } | ||||||
| 1392 | elsif (check_flag 'dynamic') { | ||||||
| 1393 | |||||||
| 1394 | # $nat_tag is used later to look up static translation | ||||||
| 1395 | # of hosts inside a dynamically translated network. | ||||||
| 1396 | 38 | 79 | $nat->{dynamic} = $nat_tag; | ||||
| 1397 | } | ||||||
| 1398 | elsif (my $pair = check_assign 'subnet_of', \&read_typed_name) { | ||||||
| 1399 | 2 | 3 | add_attribute($nat, subnet_of => $pair); | ||||
| 1400 | } | ||||||
| 1401 | else { | ||||||
| 1402 | 0 | 0 | syntax_err("Expected some valid NAT attribute"); | ||||
| 1403 | } | ||||||
| 1404 | } | ||||||
| 1405 | 136 | 305 | if ($nat->{hidden}) { | ||||
| 1406 | 37 | 78 | for my $key (keys %$nat) { | ||||
| 1407 | 74 148 | 69 278 | next if grep { $key eq $_ } qw( name hidden ); | ||||
| 1408 | 0 | 0 | error_atline("Hidden NAT must not use attribute $key"); | ||||
| 1409 | } | ||||||
| 1410 | |||||||
| 1411 | # This simplifies error checks for overlapping addresses. | ||||||
| 1412 | 37 | 60 | $nat->{dynamic} = $nat_tag; | ||||
| 1413 | } | ||||||
| 1414 | elsif ($nat->{identity}) { | ||||||
| 1415 | 9 | 21 | for my $key (keys %$nat) { | ||||
| 1416 | 18 36 | 21 69 | next if grep { $key eq $_ } qw( name identity ); | ||||
| 1417 | 0 | 0 | error_atline("Identity NAT must not use attribute $key"); | ||||
| 1418 | } | ||||||
| 1419 | 9 | 17 | $nat->{dynamic} = $nat_tag; | ||||
| 1420 | } | ||||||
| 1421 | else { | ||||||
| 1422 | 90 | 170 | defined($nat->{ip}) or error_atline('Missing IP address'); | ||||
| 1423 | } | ||||||
| 1424 | 136 | 168 | return $nat; | ||||
| 1425 | } | ||||||
| 1426 | |||||||
| 1427 | our %networks; | ||||||
| 1428 | |||||||
| 1429 | sub read_network { | ||||||
| 1430 | 1053 | 0 | 988 | my $name = shift; | |||
| 1431 | |||||||
| 1432 | # Network name without prefix "network:" is needed to build | ||||||
| 1433 | # name of ID-hosts. | ||||||
| 1434 | 1053 | 3212 | (my $net_name = $name) =~ s/^network://; | ||||
| 1435 | 1053 | 1640 | my $network = new('Network', name => $name); | ||||
| 1436 | 1053 | 1618 | $network->{private} = $private if $private; | ||||
| 1437 | 1053 | 1980 | if ($net_name =~ m,^(.*)/,) { | ||||
| 1438 | 14 | 29 | $network->{bridged} = $1; | ||||
| 1439 | } | ||||||
| 1440 | 1053 | 1313 | skip '='; | ||||
| 1441 | 1053 | 1484 | skip '\{'; | ||||
| 1442 | 1053 | 1623 | add_description($network); | ||||
| 1443 | 1053 | 956 | while (1) { | ||||
| 1444 | 2532 | 2970 | last if check '\}'; | ||||
| 1445 | 1479 | 2629 | if (my ($ip, $mask) = check_assign 'ip', \&read_ip_prefix) { | ||||
| 1446 | 1042 | 1441 | add_attribute($network, ip => $ip); | ||||
| 1447 | 1042 | 1160 | add_attribute($network, mask => $mask); | ||||
| 1448 | } | ||||||
| 1449 | elsif (check_flag 'unnumbered') { | ||||||
| 1450 | 11 | 23 | defined $network->{ip} and error_atline("Duplicate IP address"); | ||||
| 1451 | 11 | 21 | $network->{ip} = 'unnumbered'; | ||||
| 1452 | } | ||||||
| 1453 | elsif (check_flag 'has_subnets') { | ||||||
| 1454 | |||||||
| 1455 | # Duplicate use of this flag doesn't matter. | ||||||
| 1456 | 36 | 66 | $network->{has_subnets} = 1; | ||||
| 1457 | } | ||||||
| 1458 | elsif (check_flag 'crosslink') { | ||||||
| 1459 | |||||||
| 1460 | # Duplicate use of this flag doesn't matter. | ||||||
| 1461 | 10 | 18 | $network->{crosslink} = 1; | ||||
| 1462 | } | ||||||
| 1463 | elsif (my $pair = check_assign 'subnet_of', \&read_typed_name) { | ||||||
| 1464 | 30 | 54 | add_attribute($network, subnet_of => $pair); | ||||
| 1465 | } | ||||||
| 1466 | elsif (my $owner = check_assign 'owner', \&read_identifier) { | ||||||
| 1467 | 19 | 35 | add_attribute($network, owner => $owner); | ||||
| 1468 | } | ||||||
| 1469 | elsif (my $radius_attributes = check_radius_attributes) { | ||||||
| 1470 | 6 | 10 | add_attribute($network, radius_attributes => $radius_attributes); | ||||
| 1471 | } | ||||||
| 1472 | elsif (my $host_name = check_hostname()) { | ||||||
| 1473 | 201 | 497 | my $host = read_host("host:$host_name", $net_name); | ||||
| 1474 | 201 | 274 | $host->{network} = $network; | ||||
| 1475 | 201 | 301 | if (is_host($host)) { | ||||
| 1476 | 181 181 | 158 310 | push @{ $network->{hosts} }, $host; | ||||
| 1477 | 181 | 300 | $host_name = (split_typed_name($host->{name}))[1]; | ||||
| 1478 | } | ||||||
| 1479 | |||||||
| 1480 | # Managed host is stored as interface internally. | ||||||
| 1481 | elsif (is_interface($host)) { | ||||||
| 1482 | 20 20 | 18 30 | push @{ $network->{interfaces} }, $host; | ||||
| 1483 | 20 | 32 | check_interface_ip($host, $network); | ||||
| 1484 | |||||||
| 1485 | # For use in expand_group. | ||||||
| 1486 | 20 20 | 13 33 | push @{ $network->{managed_hosts} }, $host; | ||||
| 1487 | } | ||||||
| 1488 | else { | ||||||
| 1489 | 0 | 0 | internal_err; | ||||
| 1490 | } | ||||||
| 1491 | 201 | 488 | if (my $other = $hosts{$host_name}) { | ||||
| 1492 | 0 | 0 | my $where = $current_file; | ||||
| 1493 | 0 | 0 | my $other_net = $other->{network}; | ||||
| 1494 | 0 | 0 | if ($other_net ne $network) { | ||||
| 1495 | 0 | 0 | $where .= " $other_net->{file}"; | ||||
| 1496 | } | ||||||
| 1497 | 0 | 0 | err_msg("Duplicate definition of host:$host_name in $where"); | ||||
| 1498 | } | ||||||
| 1499 | 201 | 1118 | $hosts{$host_name} = $host; | ||||
| 1500 | } | ||||||
| 1501 | elsif (my $nat_tag = check_nat_name()) { | ||||||
| 1502 | 124 | 258 | my $nat = read_nat("nat:$nat_tag"); | ||||
| 1503 | 124 | 320 | ($network->{nat} && $network->{nat}->{$nat_tag}) | ||||
| 1504 | and error_atline("Duplicate NAT definition"); | ||||||
| 1505 | |||||||
| 1506 | 124 | 282 | $nat->{name} .= "($name)"; | ||||
| 1507 | 124 | 336 | $network->{nat}->{$nat_tag} = $nat; | ||||
| 1508 | } | ||||||
| 1509 | else { | ||||||
| 1510 | 0 | 0 | syntax_err("Expected some valid attribute"); | ||||
| 1511 | } | ||||||
| 1512 | } | ||||||
| 1513 | |||||||
| 1514 | # Network needs at least IP and mask to be defined. | ||||||
| 1515 | 1053 | 1422 | my $ip = $network->{ip}; | ||||
| 1516 | |||||||
| 1517 | # Use 'defined' here because IP may have value '0'. | ||||||
| 1518 | 1053 | 1565 | defined $ip or syntax_err("Missing network IP"); | ||||
| 1519 | |||||||
| 1520 | 1053 | 2228 | if ($ip eq 'unnumbered') { | ||||
| 1521 | 11 | 31 | my %ok = (ip => 1, name => 1, crosslink => 1, private => 1); | ||||
| 1522 | |||||||
| 1523 | # Unnumbered network must not have any other attributes. | ||||||
| 1524 | 11 | 25 | for my $key (keys %$network) { | ||||
| 1525 | 22 | 50 | next if $ok{$key}; | ||||
| 1526 | 0 | 0 | error_atline("Unnumbered $network->{name} must not have ", | ||||
| 1527 | ($key eq 'hosts') ? "host definition" | ||||||
| 1528 | : ($key eq 'nat') ? "nat definition" | ||||||
| 1529 | : "attribute '$key'"); | ||||||
| 1530 | } | ||||||
| 1531 | } | ||||||
| 1532 | elsif ($network->{bridged}) { | ||||||
| 1533 | 14 | 46 | my %ok = (ip => 1, mask => 1, bridged => 1, name => 1, private => 1, | ||||
| 1534 | nat => 1, owner => 1, crosslink => 1); | ||||||
| 1535 | |||||||
| 1536 | # Bridged network must not have any other attributes. | ||||||
| 1537 | 14 | 30 | for my $key (keys %$network) { | ||||
| 1538 | 57 | 98 | next if $ok{$key}; | ||||
| 1539 | 0 | 0 | error_atline( | ||||
| 1540 | "Bridged $network->{name} must not have ", | ||||||
| 1541 | ($key eq 'hosts') ? "host definition (not implemented)" | ||||||
| 1542 | : "attribute '$key'"); | ||||||
| 1543 | } | ||||||
| 1544 | 14 | 37 | if (my $hash = $network->{nat}) { | ||||
| 1545 | 0 | 0 | for my $nat_tag (sort keys %$hash) { | ||||
| 1546 | 0 | 0 | $hash->{$nat_tag}->{identity} and next; | ||||
| 1547 | 0 | 0 | delete $hash->{$nat_tag}; | ||||
| 1548 | 0 | 0 | err_msg("Only identity NAT allowed for bridged $network->{name}"); | ||||
| 1549 | 0 | 0 | last; | ||||
| 1550 | } | ||||||
| 1551 | } | ||||||
| 1552 | } | ||||||
| 1553 | else { | ||||||
| 1554 | 1028 | 1041 | my $mask = $network->{mask}; | ||||
| 1555 | 1028 1028 | 837 2015 | for my $host (@{ $network->{hosts} }) { | ||||
| 1556 | |||||||
| 1557 | # Check compatibility of host IP and network IP/mask. | ||||||
| 1558 | 181 | 323 | if (my $host_ip = $host->{ip}) { | ||||
| 1559 | 160 | 248 | if (not(match_ip($host_ip, $ip, $mask))) { | ||||
| 1560 | 0 | 0 | error_atline("$host->{name}'s IP doesn't match". | ||||
| 1561 | " network IP/mask"); | ||||||
| 1562 | } | ||||||
| 1563 | } | ||||||
| 1564 | elsif ($host->{range}) { | ||||||
| 1565 | 21 21 | 19 28 | my ($ip1, $ip2) = @{ $host->{range} }; | ||||
| 1566 | 21 | 33 | if ( | ||||
| 1567 | not( match_ip($ip1, $ip, $mask) | ||||||
| 1568 | and match_ip($ip2, $ip, $mask)) | ||||||
| 1569 | ) | ||||||
| 1570 | { | ||||||
| 1571 | 0 | 0 | error_atline("$host->{name}'s IP range doesn't match", | ||||
| 1572 | " network IP/mask"); | ||||||
| 1573 | } | ||||||
| 1574 | } | ||||||
| 1575 | else { | ||||||
| 1576 | 0 | 0 | internal_err(); | ||||
| 1577 | } | ||||||
| 1578 | |||||||
| 1579 | # Compatibility of host and network NAT will be checked later, | ||||||
| 1580 | # after inherited NAT definitions have been processed. | ||||||
| 1581 | } | ||||||
| 1582 | 1028 1028 | 878 2455 | if (@{ $network->{hosts} } and $network->{crosslink}) { | ||||
| 1583 | 1 | 2 | error_atline("Crosslink network must not have host definitions"); | ||||
| 1584 | } | ||||||
| 1585 | 1028 | 1618 | if ($network->{nat}) { | ||||
| 1586 | |||||||
| 1587 | # Check NAT definitions. | ||||||
| 1588 | 95 95 | 86 198 | for my $nat (values %{ $network->{nat} }) { | ||||
| 1589 | 124 | 251 | next if $nat->{dynamic}; | ||||
| 1590 | 52 | 123 | $nat->{mask} == $mask | ||||
| 1591 | or error_atline("Mask for non dynamic $nat->{name}", | ||||||
| 1592 | " must be equal to network mask"); | ||||||
| 1593 | } | ||||||
| 1594 | } | ||||||
| 1595 | |||||||
| 1596 | # Check and mark networks with ID-hosts. | ||||||
| 1597 | 1028 181 1028 | 807 364 1673 | if (my $id_hosts_count = grep { $_->{id} } @{ $network->{hosts} }) { | ||||
| 1598 | |||||||
| 1599 | # If one host has ID, all hosts must have ID. | ||||||
| 1600 | 13 13 | 13 24 | @{ $network->{hosts} } == $id_hosts_count | ||||
| 1601 | or error_atline("All hosts must have ID in $name"); | ||||||
| 1602 | |||||||
| 1603 | # Mark network. | ||||||
| 1604 | 13 | 17 | $network->{has_id_hosts} = 1; | ||||
| 1605 | 13 | 32 | $network->{radius_attributes} ||= {}; | ||||
| 1606 | } | ||||||
| 1607 | else { | ||||||
| 1608 | 1015 | 1860 | $network->{radius_attributes} | ||||
| 1609 | and error_atline("Attribute 'radius_attributes' is", | ||||||
| 1610 | " not allowed for $name"); | ||||||
| 1611 | } | ||||||
| 1612 | } | ||||||
| 1613 | 1053 | 1330 | return $network; | ||||
| 1614 | } | ||||||
| 1615 | |||||||
| 1616 | our %interfaces; | ||||||
| 1617 | my @virtual_interfaces; | ||||||
| 1618 | my $global_active_pathrestriction = new( | ||||||
| 1619 | 'Pathrestriction', | ||||||
| 1620 | name => 'global_pathrestriction', | ||||||
| 1621 | active_path => 1 | ||||||
| 1622 | ); | ||||||
| 1623 | |||||||
| 1624 | # Tunnel networks which are already attached to tunnel interfaces | ||||||
| 1625 | # at spoke devices. Key is crypto name, not crypto object. | ||||||
| 1626 | my %crypto2spokes; | ||||||
| 1627 | |||||||
| 1628 | # Real interfaces at crypto hub, where tunnels are attached. | ||||||
| 1629 | # Key is crypto name, not crypto object. | ||||||
| 1630 | my %crypto2hubs; | ||||||
| 1631 | |||||||
| 1632 | sub read_interface { | ||||||
| 1633 | 1485 | 0 | 1367 | my ($name) = @_; | |||
| 1634 | 1485 | 1841 | my $interface = new('Interface', name => $name); | ||||
| 1635 | |||||||
| 1636 | # Short form of interface definition. | ||||||
| 1637 | 1485 | 1815 | if (not check '=') { | ||||
| 1638 | 188 | 253 | skip ';'; | ||||
| 1639 | 188 | 284 | $interface->{ip} = 'short'; | ||||
| 1640 | 188 | 314 | return $interface; | ||||
| 1641 | } | ||||||
| 1642 | |||||||
| 1643 | 1297 | 1503 | my @secondary_interfaces = (); | ||||
| 1644 | 1297 | 985 | my $virtual; | ||||
| 1645 | 1297 | 1594 | skip '\{'; | ||||
| 1646 | 1297 | 1907 | add_description($interface); | ||||
| 1647 | 1297 | 1162 | while (1) { | ||||
| 1648 | 3889 | 4508 | last if check '\}'; | ||||
| 1649 | 2592 | 4154 | if (my @ip = check_assign_list 'ip', \&read_ip) { | ||||
| 1650 | 1226 | 1788 | add_attribute($interface, ip => shift(@ip)); | ||||
| 1651 | |||||||
| 1652 | # Build interface objects for secondary IP addresses. | ||||||
| 1653 | # These objects are named interface:router.name.2, ... | ||||||
| 1654 | 1226 | 1057 | my $counter = 2; | ||||
| 1655 | 1226 | 2182 | for my $ip (@ip) { | ||||
| 1656 | 5 | 17 | push @secondary_interfaces, | ||||
| 1657 | new('Interface', name => "$name.$counter", ip => $ip); | ||||||
| 1658 | 5 | 13 | $counter++; | ||||
| 1659 | } | ||||||
| 1660 | } | ||||||
| 1661 | elsif (check_flag 'unnumbered') { | ||||||
| 1662 | 13 | 20 | add_attribute($interface, ip => 'unnumbered'); | ||||
| 1663 | } | ||||||
| 1664 | elsif (check_flag 'negotiated') { | ||||||
| 1665 | 3 | 5 | add_attribute($interface, ip => 'negotiated'); | ||||
| 1666 | } | ||||||
| 1667 | elsif (check_flag 'loopback') { | ||||||
| 1668 | 27 | 54 | $interface->{loopback} = 1; | ||||
| 1669 | } | ||||||
| 1670 | elsif (check_flag 'vip') { | ||||||
| 1671 | 5 | 10 | $interface->{vip} = 1; | ||||
| 1672 | } | ||||||
| 1673 | elsif (check_flag 'no_in_acl') { | ||||||
| 1674 | 7 | 14 | $interface->{no_in_acl} = 1; | ||||
| 1675 | } | ||||||
| 1676 | elsif (check_flag 'dhcp_server') { | ||||||
| 1677 | 1 | 3 | $interface->{dhcp_server} = 1; | ||||
| 1678 | } | ||||||
| 1679 | |||||||
| 1680 | # Needed for the implicitly defined network of 'loopback'. | ||||||
| 1681 | elsif (my $pair = check_assign 'subnet_of', \&read_typed_name) { | ||||||
| 1682 | 4 | 6 | add_attribute($interface, subnet_of => $pair); | ||||
| 1683 | } | ||||||
| 1684 | elsif (my @pairs = check_assign_list 'hub', \&read_typed_name) { | ||||||
| 1685 | 18 | 22 | for my $pair (@pairs) { | ||||
| 1686 | 21 | 26 | my ($type, $name2) = @$pair; | ||||
| 1687 | 21 | 37 | $type eq 'crypto' or error_atline("Expected type 'crypto'"); | ||||
| 1688 | 21 21 | 21 101 | push @{ $interface->{hub} }, "$type:$name2"; | ||||
| 1689 | } | ||||||
| 1690 | } | ||||||
| 1691 | elsif ($pair = check_assign 'spoke', \&read_typed_name) { | ||||||
| 1692 | 25 | 34 | my ($type, $name2) = @$pair; | ||||
| 1693 | 25 | 43 | $type eq 'crypto' or error_atline("Expected type crypto"); | ||||
| 1694 | 25 | 64 | add_attribute($interface, spoke => "$type:$name2"); | ||||
| 1695 | } | ||||||
| 1696 | elsif (my $id = check_assign 'id', \&read_user_id) { | ||||||
| 1697 | 9 | 13 | add_attribute($interface, id => $id); | ||||
| 1698 | } | ||||||
| 1699 | elsif (defined(my $level = check_assign 'security_level', \&read_int)) { | ||||||
| 1700 | 0 | 0 | $level > 100 | ||||
| 1701 | and error_atline("Maximum value for attribute security_level", | ||||||
| 1702 | " is 100"); | ||||||
| 1703 | 0 | 0 | add_attribute($interface, security_level => $level); | ||||
| 1704 | } | ||||||
| 1705 | elsif ($pair = check_typed_name) { | ||||||
| 1706 | 11 | 17 | my ($type, $name2) = @$pair; | ||||
| 1707 | 11 | 26 | if ($type eq 'nat') { | ||||
| 1708 | 2 | 4 | skip '='; | ||||
| 1709 | 2 | 4 | skip '\{'; | ||||
| 1710 | 2 | 3 | skip 'ip'; | ||||
| 1711 | 2 | 4 | skip '='; | ||||
| 1712 | 2 | 4 | my $nat_ip = read_ip; | ||||
| 1713 | 2 | 3 | skip ';'; | ||||
| 1714 | 2 | 5 | skip '\}'; | ||||
| 1715 | 2 | 6 | $interface->{nat}->{$name2} | ||||
| 1716 | and error_atline("Duplicate NAT definition"); | ||||||
| 1717 | 2 | 7 | $interface->{nat}->{$name2} = $nat_ip; | ||||
| 1718 | } | ||||||
| 1719 | elsif ($type eq 'secondary') { | ||||||
| 1720 | |||||||
| 1721 | # Build new interface for secondary IP addresses. | ||||||
| 1722 | 9 | 26 | my $secondary = new('Interface', name => "$name.$name2"); | ||||
| 1723 | 9 | 15 | skip '='; | ||||
| 1724 | 9 | 12 | skip '\{'; | ||||
| 1725 | 9 | 10 | while (1) { | ||||
| 1726 | 18 | 23 | last if check '\}'; | ||||
| 1727 | 9 | 24 | if (my $ip = check_assign 'ip', \&read_ip) { | ||||
| 1728 | 9 | 13 | add_attribute($secondary, ip => $ip); | ||||
| 1729 | } | ||||||
| 1730 | else { | ||||||
| 1731 | 0 | 0 | syntax_err("Expected attribute IP"); | ||||
| 1732 | } | ||||||
| 1733 | } | ||||||
| 1734 | 9 | 19 | if ($secondary->{ip}) { | ||||
| 1735 | 9 | 26 | push @secondary_interfaces, $secondary; | ||||
| 1736 | } | ||||||
| 1737 | else { | ||||||
| 1738 | 0 | 0 | error_atline("Missing IP address"); | ||||
| 1739 | } | ||||||
| 1740 | } | ||||||
| 1741 | else { | ||||||
| 1742 | 0 | 0 | syntax_err("Expected nat or secondary interface definition"); | ||||
| 1743 | } | ||||||
| 1744 | } | ||||||
| 1745 | elsif (check 'virtual') { | ||||||
| 1746 | 72 | 130 | $virtual and error_atline("Duplicate virtual interface"); | ||||
| 1747 | |||||||
| 1748 | # Read attributes of redundancy protocol (VRRP/HSRP). | ||||||
| 1749 | 72 | 190 | $virtual = new( | ||||
| 1750 | 'Interface', | ||||||
| 1751 | name => "$name.virtual", | ||||||
| 1752 | redundant => 1 | ||||||
| 1753 | ); | ||||||
| 1754 | 72 | 102 | skip '='; | ||||
| 1755 | 72 | 103 | skip '\{'; | ||||
| 1756 | 72 | 68 | while (1) { | ||||
| 1757 | 158 | 183 | last if check '\}'; | ||||
| 1758 | 86 | 135 | if (my $ip = check_assign 'ip', \&read_ip) { | ||||
| 1759 | 72 | 100 | add_attribute($virtual, ip => $ip); | ||||
| 1760 | } | ||||||
| 1761 | elsif (my $type = check_assign 'type', \&read_identifier) { | ||||||
| 1762 | 14 | 28 | $xxrp_info{$type} | ||||
| 1763 | or error_atline("unknown redundancy protocol"); | ||||||
| 1764 | 14 | 18 | add_attribute($virtual, redundancy_type => $type); | ||||
| 1765 | } | ||||||
| 1766 | elsif (my $id = check_assign 'id', \&read_identifier) { | ||||||
| 1767 | 0 | 0 | $id =~ /^\d+$/ | ||||
| 1768 | or error_atline("Redundancy ID must be numeric"); | ||||||
| 1769 | 0 | 0 | $id < 256 or error_atline("Redundancy ID must be < 256"); | ||||
| 1770 | 0 | 0 | add_attribute($virtual, redundancy_id => $id); | ||||
| 1771 | } | ||||||
| 1772 | else { | ||||||
| 1773 | 0 | 0 | syntax_err("Expected valid attribute for virtual IP"); | ||||
| 1774 | } | ||||||
| 1775 | } | ||||||
| 1776 | 72 | 149 | $virtual->{ip} or error_atline("Missing virtual IP"); | ||||
| 1777 | 72 | 203 | ($virtual->{redundancy_id} && !$virtual->{redundancy_type}) and | ||||
| 1778 | syntax_err("Redundancy ID is given without redundancy protocol"); | ||||||
| 1779 | } | ||||||
| 1780 | elsif (my @tags = check_assign_list 'bind_nat', \&read_identifier) { | ||||||
| 1781 | 108 | 201 | $interface->{bind_nat} and error_atline("Duplicate NAT binding"); | ||||
| 1782 | 108 | 193 | $interface->{bind_nat} = [ unique sort @tags ]; | ||||
| 1783 | } | ||||||
| 1784 | elsif (my $hardware = check_assign 'hardware', \&read_name) { | ||||||
| 1785 | 1044 | 1411 | add_attribute($interface, hardware => $hardware); | ||||
| 1786 | } | ||||||
| 1787 | elsif (my $owner = check_assign 'owner', \&read_identifier) { | ||||||
| 1788 | 3 | 4 | add_attribute($interface, owner => $owner); | ||||
| 1789 | } | ||||||
| 1790 | elsif (my $routing = check_routing()) { | ||||||
| 1791 | 8 | 13 | add_attribute($interface, routing => $routing); | ||||
| 1792 | } | ||||||
| 1793 | elsif (@pairs = check_assign_list 'reroute_permit', \&read_typed_name) { | ||||||
| 1794 | 2 2 | 3 13 | if (grep { $_->[0] ne 'network' || ref $_->[1] } @pairs) { | ||||
| 1795 | 0 | 0 | error_atline "Must only use network names in 'reroute_permit'"; | ||||
| 1796 | 0 | 0 | @pairs = (); | ||||
| 1797 | } | ||||||
| 1798 | 2 | 4 | add_attribute($interface, reroute_permit => \@pairs); | ||||
| 1799 | } | ||||||
| 1800 | elsif (check_flag 'disabled') { | ||||||
| 1801 | 3 | 9 | $interface->{disabled} = 1; | ||||
| 1802 | } | ||||||
| 1803 | elsif (check_flag 'no_check') { | ||||||
| 1804 | 3 | 9 | $interface->{no_check} = 1; | ||||
| 1805 | } | ||||||
| 1806 | else { | ||||||
| 1807 | 0 | 0 | syntax_err('Expected some valid attribute'); | ||||
| 1808 | } | ||||||
| 1809 | } | ||||||
| 1810 | |||||||
| 1811 | # Interface at bridged network | ||||||
| 1812 | # - without IP is interface of bridge, | ||||||
| 1813 | # - with IP is interface of router. | ||||||
| 1814 | 1297 | 2509 | if ($name =~ m,/,) { | ||||
| 1815 | 24 | 62 | $interface->{ip} ||= 'bridged'; | ||||
| 1816 | } | ||||||
| 1817 | |||||||
| 1818 | # Swap virtual interface and main interface | ||||||
| 1819 | # or take virtual interface as main interface if no main IP available. | ||||||
| 1820 | # Subsequent code becomes simpler if virtual interface is main interface. | ||||||
| 1821 | 1297 | 1609 | if ($virtual) { | ||||
| 1822 | 72 | 136 | if (my $ip = $interface->{ip}) { | ||||
| 1823 | 64 | 160 | if ($ip =~ /^(unnumbered|negotiated|short|bridged)$/) { | ||||
| 1824 | 0 | 0 | error_atline("No virtual IP supported for $ip interface"); | ||||
| 1825 | } | ||||||
| 1826 | |||||||
| 1827 | # Move main IP to secondary. | ||||||
| 1828 | 64 | 98 | my $secondary = | ||||
| 1829 | new('Interface', name => $interface->{name}, ip => $ip); | ||||||
| 1830 | 64 | 57 | push @secondary_interfaces, $secondary; | ||||
| 1831 | |||||||
| 1832 | # But we need the original main interface | ||||||
| 1833 | # when handling auto interfaces. | ||||||
| 1834 | 64 | 84 | $interface->{orig_main} = $secondary; | ||||
| 1835 | } | ||||||
| 1836 | 72 72 | 169 103 | @{$interface}{qw(name ip redundant redundancy_type redundancy_id)} = | ||||
| 1837 | 72 | 69 | @{$virtual}{qw(name ip redundant redundancy_type redundancy_id)}; | ||||
| 1838 | 72 | 98 | push @virtual_interfaces, $interface; | ||||
| 1839 | } | ||||||
| 1840 | else { | ||||||
| 1841 | 1225 | 2218 | $interface->{ip} ||= 'short'; | ||||
| 1842 | } | ||||||
| 1843 | 1297 | 2035 | if ($interface->{nat}) { | ||||
| 1844 | 2 | 6 | if ($interface->{ip} =~ /^(unnumbered|negotiated|short|bridged)$/) { | ||||
| 1845 | 0 | 0 | error_atline("No NAT supported for $interface->{ip} interface"); | ||||
| 1846 | } | ||||||
| 1847 | } | ||||||
| 1848 | 1297 | 1898 | if ($interface->{vip}) { | ||||
| 1849 | 5 | 9 | $interface->{loopback} = 1; | ||||
| 1850 | 5 | 10 | $interface->{hardware} and | ||||
| 1851 | error_atline("'vip' interface must not have attribute 'hardware'"); | ||||||
| 1852 | 5 | 5 | $interface->{hardware} = 'VIP'; | ||||
| 1853 | } | ||||||
| 1854 | 1297 | 2214 | if ($interface->{owner} && !$interface->{vip}) { | ||||
| 1855 | 0 | 0 | error_atline("Must use attribute 'owner' only at 'vip' interface"); | ||||
| 1856 | 0 | 0 | delete $interface->{owner}; | ||||
| 1857 | } | ||||||
| 1858 | 1297 | 2549 | if ($interface->{loopback}) { | ||||
| 1859 | 32 | 128 | my %copy = %$interface; | ||||
| 1860 | |||||||
| 1861 | # Only these attributes are valid. | ||||||
| 1862 | delete @copy{ | ||||||
| 1863 | 32 | 104 | qw(name ip nat bind_nat hardware loopback subnet_of | ||||
| 1864 | owner redundant redundancy_type redundancy_id vip) | ||||||
| 1865 | }; | ||||||
| 1866 | 32 | 58 | if (keys %copy) { | ||||
| 1867 | 0 0 | 0 0 | my $attr = join ", ", map { "'$_'" } keys %copy; | ||||
| 1868 | 0 | 0 | my $type = $interface->{vip} ? "'vip'" : 'loopback'; | ||||
| 1869 | 0 | 0 | error_atline("Invalid attributes $attr for $type interface"); | ||||
| 1870 | } | ||||||
| 1871 | 32 | 104 | if ($interface->{ip} =~ /^(unnumbered|negotiated|short|bridged)$/) { | ||||
| 1872 | 0 | 0 | my $type = $interface->{vip} ? "'vip'" : 'Loopback'; | ||||
| 1873 | 0 | 0 | error_atline("$type interface must not be $interface->{ip}"); | ||||
| 1874 | 0 | 0 | $interface->{disabled} = 1; | ||||
| 1875 | } | ||||||
| 1876 | } | ||||||
| 1877 | elsif ($interface->{subnet_of}) { | ||||||
| 1878 | 0 | 0 | error_atline("Attribute 'subnet_of' is only valid", | ||||
| 1879 | " for loopback interface"); | ||||||
| 1880 | } | ||||||
| 1881 | 1297 | 2332 | if ($interface->{ip} eq 'bridged') { | ||||
| 1882 | 14 | 33 | my %ok = (ip => 1, hardware => 1, name => 1, bind_nat => 1); | ||||
| 1883 | 14 42 | 29 87 | if (my @extra = grep { !$ok{$_} } keys %$interface) { | ||||
| 1884 | 0 0 | 0 0 | my $attr = join ", ", map { "'$_'" } @extra; | ||||
| 1885 | 0 | 0 | error_atline("Invalid attributes $attr for bridged interface"); | ||||
| 1886 | } | ||||||
| 1887 | } | ||||||
| 1888 | 1297 | 1683 | if (my $crypto = $interface->{spoke}) { | ||||
| 1889 | @secondary_interfaces | ||||||
| 1890 | 25 | 41 | and error_atline("Interface with attribute 'spoke'", | ||||
| 1891 | " must not have secondary interfaces"); | ||||||
| 1892 | 25 | 37 | $interface->{hub} | ||||
| 1893 | and error_atline("Interface with attribute 'spoke'", | ||||||
| 1894 | " must not have attribute 'hub'"); | ||||||
| 1895 | } | ||||||
| 1896 | else { | ||||||
| 1897 | 1272 | 1937 | $interface->{id} | ||||
| 1898 | and error_atline("Attribute 'id' is only valid for 'spoke' interface"); | ||||||
| 1899 | } | ||||||
| 1900 | 1297 | 1897 | if (my $crypto_list = $interface->{hub}) { | ||||
| 1901 | 18 | 44 | if ($interface->{ip} =~ /^(unnumbered|negotiated|short|bridged)$/) { | ||||
| 1902 | 0 | 0 | error_atline("Crypto hub must not be $interface->{ip} interface"); | ||||
| 1903 | } | ||||||
| 1904 | 18 | 27 | for my $crypto (@$crypto_list) { | ||||
| 1905 | 21 21 | 17 62 | push @{ $crypto2hubs{$crypto} }, $interface; | ||||
| 1906 | } | ||||||
| 1907 | } | ||||||
| 1908 | 1297 | 1945 | if (@secondary_interfaces) { | ||||
| 1909 | 74 | 173 | if ($interface->{ip} =~ /^(unnumbered|negotiated|short|bridged)$/) { | ||||
| 1910 | 0 | 0 | error_atline("\u$interface->{ip} interface must not have", | ||||
| 1911 | " secondary IP address"); | ||||||
| 1912 | 0 | 0 | @secondary_interfaces = (); | ||||
| 1913 | } | ||||||
| 1914 | } | ||||||
| 1915 | 1297 | 1664 | for my $secondary (@secondary_interfaces) { | ||||
| 1916 | 78 | 91 | $secondary->{main_interface} = $interface; | ||||
| 1917 | 78 | 77 | for my $key (qw(hardware bind_nat routing disabled)) { | ||||
| 1918 | 312 | 679 | $secondary->{$key} = $interface->{$key} if $interface->{$key}; | ||||
| 1919 | } | ||||||
| 1920 | } | ||||||
| 1921 | 1297 | 2327 | return $interface, @secondary_interfaces; | ||||
| 1922 | } | ||||||
| 1923 | |||||||
| 1924 | # PIX firewalls have a security level associated with each interface. | ||||||
| 1925 | # Use attribute 'security_level' or | ||||||
| 1926 | # try to derive the level from the interface name. | ||||||
| 1927 | sub set_pix_interface_level { | ||||||
| 1928 | 258 | 0 | 264 | my ($router) = @_; | |||
| 1929 | 258 258 | 208 373 | for my $hardware (@{ $router->{hardware} }) { | ||||
| 1930 | 551 | 569 | my $hwname = $hardware->{name}; | ||||
| 1931 | 551 | 413 | my $level; | ||||
| 1932 | 551 | 455 | if ( | ||||
| 1933 | 556 556 | 4078 879 | my @levels = grep { defined($_) } | ||||
| 1934 | 551 | 678 | map { $_->{security_level} } @{ $hardware->{interfaces} } | ||||
| 1935 | ) | ||||||
| 1936 | { | ||||||
| 1937 | 0 | 0 | if (@levels >= 2 && !equal(@levels)) { | ||||
| 1938 | 0 | 0 | err_msg "Must not use different values", | ||||
| 1939 | " for attribute 'security_level'\n", | ||||||
| 1940 | " at $router->{name}, hardware $hwname: ", join(',', @levels); | ||||||
| 1941 | } | ||||||
| 1942 | else { | ||||||
| 1943 | 0 | 0 | $level = $levels[0]; | ||||
| 1944 | } | ||||||
| 1945 | } | ||||||
| 1946 | elsif ($hwname =~ 'inside') { | ||||||
| 1947 | 66 | 68 | $level = 100; | ||||
| 1948 | } | ||||||
| 1949 | elsif ($hwname =~ 'outside') { | ||||||
| 1950 | 64 | 62 | $level = 0; | ||||
| 1951 | } | ||||||
| 1952 | |||||||
| 1953 | # It is not necessary the find the exact level; what we need to know | ||||||
| 1954 | # is the relation of the security levels to each other. | ||||||
| 1955 | elsif (($level) = ($hwname =~ /(\d+)$/) and $level <= 100) { | ||||||
| 1956 | } | ||||||
| 1957 | else { | ||||||
| 1958 | 19 | 19 | $level = 50; | ||||
| 1959 | } | ||||||
| 1960 | 551 | 1190 | $hardware->{level} = $level; | ||||
| 1961 | } | ||||||
| 1962 | 258 | 326 | return; | ||||
| 1963 | } | ||||||
| 1964 | |||||||
| 1965 | my $bind_nat0 = []; | ||||||
| 1966 | |||||||
| 1967 | our %routers; | ||||||
| 1968 | |||||||
| 1969 | sub read_router { | ||||||
| 1970 | 650 | 0 | 628 | my $name = shift; | |||
| 1971 | |||||||
| 1972 | # Extract | ||||||
| 1973 | # - router name without prefix "router:", needed to build interface name | ||||||
| 1974 | # - optional vrf name | ||||||
| 1975 | 650 | 3062 | my ($rname, $device_name, $vrf) = | ||||
| 1976 | $name =~ /^ router : ( (.*?) (?: \@ (.*) )? ) $/x; | ||||||
| 1977 | 650 | 1049 | my $router = new('Router', name => $name, device_name => $device_name); | ||||
| 1978 | 650 | 1083 | if (defined $vrf) { | ||||
| 1979 | |||||||
| 1980 | # VRF value "0" would be interpreted as false by perl. | ||||||
| 1981 | 6 | 9 | $vrf or error_atline("Must not use '$vrf' as VRF value"); | ||||
| 1982 | 6 | 11 | $router->{vrf} = $vrf; | ||||
| 1983 | } | ||||||
| 1984 | 650 | 809 | skip '='; | ||||
| 1985 | 650 | 906 | skip '\{'; | ||||
| 1986 | 650 | 982 | add_description($router); | ||||
| 1987 | 650 | 612 | while (1) { | ||||
| 1988 | 3284 | 4035 | last if check '\}'; | ||||
| 1989 | 2634 | 3594 | if (my $managed = check_managed()) { | ||||
| 1990 | 453 | 919 | $router->{managed} | ||||
| 1991 | and error_atline("Redefining 'managed' attribute"); | ||||||
| 1992 | 453 | 688 | $router->{managed} = $managed; | ||||
| 1993 | } | ||||||
| 1994 | elsif (my @filter_only = check_assign_list('filter_only', | ||||||
| 1995 | \&read_ip_prefix_pair)) | ||||||
| 1996 | { | ||||||
| 1997 | 26 | 39 | add_attribute($router, filter_only => \@filter_only); | ||||
| 1998 | } | ||||||
| 1999 | elsif (my $model = check_model()) { | ||||||
| 2000 | 465 | 638 | add_attribute($router, model => $model); | ||||
| 2001 | } | ||||||
| 2002 | elsif (check_flag 'no_group_code') { | ||||||
| 2003 | 0 | 0 | $router->{no_group_code} = 1; | ||||
| 2004 | } | ||||||
| 2005 | elsif (check_flag 'no_crypto_filter') { | ||||||
| 2006 | 8 | 17 | $router->{no_crypto_filter} = 1; | ||||
| 2007 | } | ||||||
| 2008 | elsif (check_flag 'no_protect_self') { | ||||||
| 2009 | 1 | 2 | $router->{no_protect_self} = 1; | ||||
| 2010 | } | ||||||
| 2011 | elsif (check_flag 'strict_secondary') { | ||||||
| 2012 | 0 | 0 | $router->{strict_secondary} = 1; | ||||
| 2013 | } | ||||||
| 2014 | elsif (check_flag 'log_deny') { | ||||||
| 2015 | 1 | 3 | $router->{log_deny} = 1; | ||||
| 2016 | } | ||||||
| 2017 | elsif (my $routing = check_routing()) { | ||||||
| 2018 | 133 | 195 | add_attribute($router, routing => $routing); | ||||
| 2019 | } | ||||||
| 2020 | elsif (my $owner = check_assign 'owner', \&read_identifier) { | ||||||
| 2021 | 1 | 2 | add_attribute($router, owner => $owner); | ||||
| 2022 | } | ||||||
| 2023 | elsif (my $radius_attributes = check_radius_attributes) { | ||||||
| 2024 | 8 | 13 | add_attribute($router, radius_attributes => $radius_attributes); | ||||
| 2025 | } | ||||||
| 2026 | elsif (my $pair = check_assign('policy_distribution_point', | ||||||
| 2027 | \&read_typed_name)) | ||||||
| 2028 | { | ||||||
| 2029 | 8 | 13 | add_attribute($router, policy_distribution_point => $pair); | ||||
| 2030 | } | ||||||
| 2031 | elsif (my @list = check_assign_list('general_permit', | ||||||
| 2032 | \&read_typed_name_or_simple_protocol)) | ||||||
| 2033 | { | ||||||
| 2034 | 11 | 20 | add_attribute($router, general_permit => \@list); | ||||
| 2035 | } | ||||||
| 2036 | else { | ||||||
| 2037 | 1519 | 1906 | my $pair = read_typed_name; | ||||
| 2038 | 1519 | 1988 | my ($type, $name2) = @$pair; | ||||
| 2039 | 1519 | 3147 | if ($type eq 'log') { | ||||
| 2040 | 34 | 76 | defined($router->{log}->{$name2}) | ||||
| 2041 | and error_atline("Duplicate 'log' definition"); | ||||||
| 2042 | 34 | 45 | my $modifier = check('=') ? read_identifier() : 0; | ||||
| 2043 | 34 | 62 | $router->{log}->{$name2} = $modifier; | ||||
| 2044 | 34 | 46 | skip(';'); | ||||
| 2045 | 34 | 85 | next; | ||||
| 2046 | } | ||||||
| 2047 | elsif ($type ne 'interface') { | ||||||
| 2048 | 0 | 0 | syntax_err("Expected interface or log definition"); | ||||
| 2049 | } | ||||||
| 2050 | |||||||
| 2051 | # Derive interface name from router name. | ||||||
| 2052 | 1485 | 2518 | my $iname = "$rname.$name2"; | ||||
| 2053 | 1485 | 3487 | for my $interface (read_interface "interface:$iname") { | ||||
| 2054 | 1563 1563 | 1208 2286 | push @{ $router->{interfaces} }, $interface; | ||||
| 2055 | 1563 | 4639 | ($iname = $interface->{name}) =~ s/interface://; | ||||
| 2056 | 1563 | 3197 | if ($interfaces{$iname}) { | ||||
| 2057 | 3 | 8 | error_atline("Redefining $interface->{name}"); | ||||
| 2058 | } | ||||||
| 2059 | |||||||
| 2060 | # Assign interface to global hash of interfaces. | ||||||
| 2061 | 1563 | 2288 | $interfaces{$iname} = $interface; | ||||
| 2062 | |||||||
| 2063 | # Link interface with router object. | ||||||
| 2064 | 1563 | 1601 | $interface->{router} = $router; | ||||
| 2065 | |||||||
| 2066 | # Link interface with network name (will be resolved later). | ||||||
| 2067 | 1563 | 1846 | $interface->{network} = $name2; | ||||
| 2068 | |||||||
| 2069 | # Set private attribute of interface. | ||||||
| 2070 | 1563 | 5774 | $interface->{private} = $private if $private; | ||||
| 2071 | } | ||||||
| 2072 | } | ||||||
| 2073 | } | ||||||
| 2074 | |||||||
| 2075 | 650 | 867 | my $model = $router->{model}; | ||||
| 2076 | |||||||
| 2077 | # Owner at vip interfaces is allowed for managed and unmanaged | ||||||
| 2078 | # devices and hence must be checked for both. | ||||||
| 2079 | { | ||||||
| 2080 | 650 650 | 529 494 | my $error; | ||||
| 2081 | 650 650 | 530 944 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 2082 | 1563 | 3171 | if ($interface->{vip} && !($model && $model->{has_vip})) { | ||||
| 2083 | 2 | 2 | $error = 1; | ||||
| 2084 | |||||||
| 2085 | # Prevent further errors. | ||||||
| 2086 | 2 | 3 | delete $interface->{vip}; | ||||
| 2087 | 2 | 4 | delete $interface->{owner}; | ||||
| 2088 | } | ||||||
| 2089 | } | ||||||
| 2090 | 650 | 1145 | if ($error) { | ||||
| 2091 | 2 12 | 9 15 | my $valid = join(', ', grep({ $router_info{$_}->{has_vip} } | ||||
| 2092 | sort keys %router_info)); | ||||||
| 2093 | 2 | 8 | err_msg("Must not use attribute 'vip' at $name\n", | ||||
| 2094 | " 'vip' is only allowed for model $valid"); | ||||||
| 2095 | } | ||||||
| 2096 | } | ||||||
| 2097 | |||||||
| 2098 | 650 | 1102 | if (my $managed = $router->{managed}) { | ||||
| 2099 | 453 | 423 | my $all_routing = $router->{routing}; | ||||
| 2100 | |||||||
| 2101 | 453 | 723 | unless ($model) { | ||||
| 2102 | 0 | 0 | err_msg("Missing 'model' for managed $name"); | ||||
| 2103 | |||||||
| 2104 | # Prevent further errors. | ||||||
| 2105 | 0 | 0 | $router->{model} = { name => 'unknown' }; | ||||
| 2106 | } | ||||||
| 2107 | |||||||
| 2108 | # Router is semi_managed if only routes are generated. | ||||||
| 2109 | 453 | 747 | if ($managed eq 'routing_only') { | ||||
| 2110 | 6 | 7 | $router->{semi_managed} = 1; | ||||
| 2111 | 6 | 8 | $router->{routing_only} = 1; | ||||
| 2112 | 6 | 11 | delete $router->{managed}; | ||||
| 2113 | } | ||||||
| 2114 | |||||||
| 2115 | 453 | 868 | $router->{vrf} | ||||
| 2116 | and not $model->{can_vrf} | ||||||
| 2117 | and err_msg("Must not use VRF at $name", | ||||||
| 2118 | " of model $model->{name}"); | ||||||
| 2119 | |||||||
| 2120 | # Create objects representing hardware interfaces. | ||||||
| 2121 | # All logical interfaces using the same hardware are linked | ||||||
| 2122 | # to the same hardware object. | ||||||
| 2123 | 453 | 360 | my %hardware; | ||||
| 2124 | 453 453 | 361 605 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 2125 | |||||||
| 2126 | # Managed router must not have short interface. | ||||||
| 2127 | 1079 | 1633 | if ($interface->{ip} eq 'short') { | ||||
| 2128 | 1 | 4 | err_msg | ||||
| 2129 | "Short definition of $interface->{name} not allowed"; | ||||||
| 2130 | } | ||||||
| 2131 | |||||||
| 2132 | 1079 | 1104 | my $hw_name = $interface->{hardware}; | ||||
| 2133 | |||||||
| 2134 | # Interface of managed router needs to have a hardware | ||||||
| 2135 | # name. | ||||||
| 2136 | 1079 | 1460 | if (!$hw_name) { | ||||
| 2137 | |||||||
| 2138 | # Prevent duplicate error message. | ||||||
| 2139 | 1 | 3 | if ($interface->{ip} ne 'short') { | ||||
| 2140 | 1 | 3 | err_msg("Missing 'hardware' for $interface->{name}"); | ||||
| 2141 | } | ||||||
| 2142 | |||||||
| 2143 | # Prevent further errors. | ||||||
| 2144 | 1 | 2 | $hw_name = 'unknown'; | ||||
| 2145 | } | ||||||
| 2146 | |||||||
| 2147 | 1079 | 792 | my $hardware; | ||||
| 2148 | 1079 | 1645 | if ($hardware = $hardware{$hw_name}) { | ||||
| 2149 | |||||||
| 2150 | # All logical interfaces of one hardware interface | ||||||
| 2151 | # need to use the same NAT binding, | ||||||
| 2152 | # because NAT operates on hardware, not on logic. | ||||||
| 2153 | 65 | 322 | aref_eq( | ||||
| 2154 | $interface->{bind_nat} || $bind_nat0, | ||||||
| 2155 | $hardware->{bind_nat} || $bind_nat0 | ||||||
| 2156 | ) | ||||||
| 2157 | or err_msg "All logical interfaces of $hw_name\n", | ||||||
| 2158 | " at $name must use identical NAT binding"; | ||||||
| 2159 | } | ||||||
| 2160 | else { | ||||||
| 2161 | 1014 | 1891 | $hardware = { name => $hw_name, loopback => 1 }; | ||||
| 2162 | 1014 | 1366 | $hardware{$hw_name} = $hardware; | ||||
| 2163 | 1014 1014 | 772 1322 | push @{ $router->{hardware} }, $hardware; | ||||
| 2164 | 1014 | 1652 | if (my $nat = $interface->{bind_nat}) { | ||||
| 2165 | 67 | 76 | $hardware->{bind_nat} = $nat; | ||||
| 2166 | } | ||||||
| 2167 | |||||||
| 2168 | # Hardware name 'VIP' is used internally at loadbalancers. | ||||||
| 2169 | 1014 | 1817 | $hw_name eq 'VIP' | ||||
| 2170 | and $model->{has_vip} | ||||||
| 2171 | and not $interface->{vip} | ||||||
| 2172 | and err_msg("Must not use hardware 'VIP' at", | ||||||
| 2173 | " $interface->{name}"); | ||||||
| 2174 | } | ||||||
| 2175 | 1079 | 1054 | $interface->{hardware} = $hardware; | ||||
| 2176 | |||||||
| 2177 | # Hardware keeps attribute {loopback} only if all | ||||||
| 2178 | # interfaces have attribute {loopback}. | ||||||
| 2179 | 1079 | 1561 | if (!$interface->{loopback}) { | ||||
| 2180 | 1054 | 1226 | delete $hardware->{loopback}; | ||||
| 2181 | } | ||||||
| 2182 | |||||||
| 2183 | # Remember, which logical interfaces are bound | ||||||
| 2184 | # to which hardware. | ||||||
| 2185 | 1079 1079 | 805 1742 | push @{ $hardware->{interfaces} }, $interface; | ||||
| 2186 | |||||||
| 2187 | # Don't allow 'routing=manual' at single interface, because | ||||||
| 2188 | # approve would remove manual routes otherwise. | ||||||
| 2189 | # Approve only leaves routes unchanged, if Netspoc generates | ||||||
| 2190 | # no routes at all. | ||||||
| 2191 | 1079 | 1651 | if ((my $routing = $interface->{routing})) { | ||||
| 2192 | 8 | 16 | $routing->{name} eq 'manual' and | ||||
| 2193 | warn_msg("'routing=manual' must only be applied", | ||||||
| 2194 | " to router, not to $interface->{name}"); | ||||||
| 2195 | } | ||||||
| 2196 | |||||||
| 2197 | # Interface inherits routing attribute from router. | ||||||
| 2198 | 1079 | 1427 | if ($all_routing) { | ||||
| 2199 | 331 | 883 | $interface->{routing} ||= $all_routing; | ||||
| 2200 | } | ||||||
| 2201 | 1079 | 3320 | if ((my $routing = $interface->{routing}) && | ||||
| 2202 | $interface->{ip} eq 'unnumbered') | ||||||
| 2203 | { | ||||||
| 2204 | 0 | 0 | my $rname = $routing->{name}; | ||||
| 2205 | 0 | 0 | $rname =~ /^(?:manual|dynamic)$/ or | ||||
| 2206 | error_atline("Routing $rname not supported", | ||||||
| 2207 | " for unnumbered interface"); | ||||||
| 2208 | } | ||||||
| 2209 | } | ||||||
| 2210 | } | ||||||
| 2211 | 650 | 1090 | if (my $managed = $router->{managed}) { | ||||
| 2212 | 447 | 855 | if ($managed =~ /^local/) { | ||||
| 2213 | 27 | 49 | $router->{filter_only} or | ||||
| 2214 | err_msg("Missing attribute 'filter_only' for $name"); | ||||||
| 2215 | 27 | 44 | $model->{has_io_acl} and | ||||
| 2216 | err_msg("Must not use 'managed = $managed' at $name", | ||||||
| 2217 | " of model $model->{name}"); | ||||||
| 2218 | } | ||||||
| 2219 | 447 | 871 | $router->{log_deny} | ||||
| 2220 | and not $model->{can_log_deny} | ||||||
| 2221 | and err_msg("Must not use attribute 'log_deny' at $name", | ||||||
| 2222 | " of model $model->{name}"); | ||||||
| 2223 | |||||||
| 2224 | 447 | 707 | if (my $hash = $router->{log}) { | ||||
| 2225 | 19 | 29 | if (my $log_modifiers = $model->{log_modifiers}) { | ||||
| 2226 | 19 | 53 | for my $name2 (sort keys %$hash) { | ||||
| 2227 | |||||||
| 2228 | # 0: simple unmodified 'log' statement. | ||||||
| 2229 | 34 | 65 | my $modifier = $hash->{$name2} or next; | ||||
| 2230 | |||||||
| 2231 | 31 | 67 | $log_modifiers->{$modifier} and next; | ||||
| 2232 | |||||||
| 2233 | 3 | 12 | my $valid = join('|', sort keys %$log_modifiers); | ||||
| 2234 | 3 | 11 | my $what = "'log:$name2 = $modifier' at $name" . | ||||
| 2235 | " of model $model->{name}"; | ||||||
| 2236 | 3 | 6 | if ($valid) { | ||||
| 2237 | 2 | 7 | err_msg("Invalid $what\n Expected one of: $valid"); | ||||
| 2238 | } | ||||||
| 2239 | else { | ||||||
| 2240 | 1 | 4 | err_msg("Unexpected $what\n Use 'log:$name2;' only."); | ||||
| 2241 | } | ||||||
| 2242 | } | ||||||
| 2243 | } | ||||||
| 2244 | else { | ||||||
| 2245 | 0 | 0 | my ($name2) = sort keys %$hash; | ||||
| 2246 | 0 | 0 | err_msg("Must not use attribute 'log:$name2' at $name", | ||||
| 2247 | " of model $model->{name}"); | ||||||
| 2248 | } | ||||||
| 2249 | } | ||||||
| 2250 | |||||||
| 2251 | 447 | 861 | $router->{no_protect_self} | ||||
| 2252 | and not $model->{need_protect} | ||||||
| 2253 | and err_msg("Must not use attribute 'no_protect_self' at $name", | ||||||
| 2254 | " of model $model->{name}"); | ||||||
| 2255 | 447 | 727 | if ($model->{need_protect}) { | ||||
| 2256 | 165 | 332 | $router->{need_protect} = !delete $router->{no_protect_self}; | ||||
| 2257 | } | ||||||
| 2258 | |||||||
| 2259 | 447 | 826 | $router->{strict_secondary} | ||||
| 2260 | and $managed !~ /secondary$/ | ||||||
| 2261 | and err_msg("Must not use attribute 'strict_secondary' at $name.\n", | ||||||
| 2262 | " Only valid with 'managed = secondary|local_secondary'"); | ||||||
| 2263 | |||||||
| 2264 | # Detailed interface processing for managed routers. | ||||||
| 2265 | 447 447 | 369 624 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 2266 | 1067 | 1813 | if (defined $interface->{security_level} | ||||
| 2267 | && !$model->{has_interface_level}) | ||||||
| 2268 | { | ||||||
| 2269 | 0 | 0 | warn_msg("Ignoring attribute 'security_level'", | ||||
| 2270 | " at $interface->{name}"); | ||||||
| 2271 | } | ||||||
| 2272 | 1067 | 3121 | if ($interface->{hub} or $interface->{spoke}) { | ||||
| 2273 | 21 | 37 | $model->{crypto} | ||||
| 2274 | or err_msg "Crypto not supported for $name", | ||||||
| 2275 | " of model $model->{name}"; | ||||||
| 2276 | } | ||||||
| 2277 | 1067 | 2121 | if ($interface->{no_check} | ||||
| 2278 | and not($interface->{hub} and $model->{do_auth})) | ||||||
| 2279 | { | ||||||
| 2280 | 0 | 0 | delete $interface->{no_check}; | ||||
| 2281 | 0 | 0 | warn_msg("Ignoring attribute 'no_check' at $interface->{name}"); | ||||
| 2282 | } | ||||||
| 2283 | } | ||||||
| 2284 | |||||||
| 2285 | # Collect bridged interfaces of this device and check | ||||||
| 2286 | # existence of corresponding layer3 device. | ||||||
| 2287 | 447 | 442 | my %layer3_seen; | ||||
| 2288 | 447 447 | 388 551 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 2289 | 1067 | 1945 | next if not $interface->{ip} eq 'bridged'; | ||||
| 2290 | 14 | 68 | (my $layer3_name = $interface->{name}) =~ s/^interface:(.*)\/.*/$1/; | ||||
| 2291 | 14 | 15 | my $layer3_intf; | ||||
| 2292 | 14 | 33 | if (exists $layer3_seen{$layer3_name}) { | ||||
| 2293 | 7 | 8 | $layer3_intf = $layer3_seen{$layer3_name}; | ||||
| 2294 | } | ||||||
| 2295 | elsif ($layer3_intf = $interfaces{$layer3_name}) { | ||||||
| 2296 | |||||||
| 2297 | # Mark layer3 interface as loopback interface internally, | ||||||
| 2298 | # because we only have layer2 networks and no layer3 network. | ||||||
| 2299 | 7 | 9 | $layer3_intf->{loopback} = 1; | ||||
| 2300 | |||||||
| 2301 | # Mark layer3 interface as such to prevent warning in | ||||||
| 2302 | # check_subnets. | ||||||
| 2303 | 7 | 7 | $layer3_intf->{is_layer3} = 1; | ||||
| 2304 | |||||||
| 2305 | 7 | 14 | if ($model->{class} eq 'ASA') { | ||||
| 2306 | 7 | 16 | $layer3_intf->{hardware}->{name} eq 'device' | ||||
| 2307 | or | ||||||
| 2308 | err_msg("Layer3 $interface->{name} must use 'hardware'", | ||||||
| 2309 | " named 'device' for model 'ASA'"); | ||||||
| 2310 | } | ||||||
| 2311 | 7 | 23 | if (my ($no_ip) = $layer3_intf->{ip} =~ | ||||
| 2312 | /^(unnumbered|negotiated|short|bridged)$/) | ||||||
| 2313 | { | ||||||
| 2314 | 0 | 0 | err_msg( | ||||
| 2315 | "Layer3 $layer3_intf->{name}", | ||||||
| 2316 | " must not be $no_ip" | ||||||
| 2317 | ); | ||||||
| 2318 | |||||||
| 2319 | # Prevent further errors. | ||||||
| 2320 | 0 | 0 | $layer3_intf->{disabled} = 1; | ||||
| 2321 | 0 | 0 | $layer3_intf = undef; | ||||
| 2322 | } | ||||||
| 2323 | } | ||||||
| 2324 | else { | ||||||
| 2325 | 0 | 0 | err_msg("Must define interface:$layer3_name for corresponding", | ||||
| 2326 | " bridge interfaces"); | ||||||
| 2327 | } | ||||||
| 2328 | |||||||
| 2329 | # Link bridged interface to corresponding layer3 interface. | ||||||
| 2330 | # Used in path_auto_interfaces. | ||||||
| 2331 | 14 | 16 | $interface->{layer3_interface} = $layer3_intf; | ||||
| 2332 | 14 | 24 | $layer3_seen{$layer3_name} = $layer3_intf; | ||||
| 2333 | } | ||||||
| 2334 | |||||||
| 2335 | # Delete secondary interface of layer3 interface. | ||||||
| 2336 | # This prevents irritating error messages later. | ||||||
| 2337 | 447 | 823 | if (keys %layer3_seen) { | ||||
| 2338 | 7 | 6 | my $changed; | ||||
| 2339 | 7 7 | 7 12 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 2340 | 21 | 36 | my $main = $interface->{main_interface} or next; | ||||
| 2341 | 0 | 0 | if ($main->{is_layer3}) { | ||||
| 2342 | 0 | 0 | err_msg("Layer3 $main->{name} must not have", | ||||
| 2343 | " secondary $interface->{name}"); | ||||||
| 2344 | 0 | 0 | $interface = undef; | ||||
| 2345 | 0 | 0 | $changed = 1; | ||||
| 2346 | } | ||||||
| 2347 | } | ||||||
| 2348 | 7 0 0 | 13 0 0 | $router->{interfaces} = [ grep { $_ } @{ $router->{interfaces} } ] | ||||
| 2349 | if $changed; | ||||||
| 2350 | } | ||||||
| 2351 | 447 | 738 | if ($model->{has_interface_level}) { | ||||
| 2352 | 258 | 379 | set_pix_interface_level($router); | ||||
| 2353 | } | ||||||
| 2354 | 447 | 817 | if ($managed =~ /^local/) { | ||||
| 2355 | 27 54 27 | 21 89 35 | grep { $_->{bind_nat} } @{ $router->{interfaces} } | ||||
| 2356 | and err_msg "Attribute 'bind_nat' is not allowed", | ||||||
| 2357 | " at interface of $name with 'managed = $managed'"; | ||||||
| 2358 | } | ||||||
| 2359 | 447 | 639 | if ($model->{do_auth}) { | ||||
| 2360 | |||||||
| 2361 | 8 14 8 | 7 26 13 | grep { $_->{hub} } @{ $router->{interfaces} } | ||||
| 2362 | or err_msg "Attribute 'hub' needs to be defined", | ||||||
| 2363 | " at an interface of $name of model $model->{name}"; | ||||||
| 2364 | |||||||
| 2365 | # Don't support NAT for VPN, otherwise code generation for VPN | ||||||
| 2366 | # devices will become more difficult. | ||||||
| 2367 | 8 14 8 | 4 23 10 | grep { $_->{bind_nat} } @{ $router->{interfaces} } | ||||
| 2368 | and err_msg "Attribute 'bind_nat' is not allowed", | ||||||
| 2369 | " at interface of $name of model $model->{name}"; | ||||||
| 2370 | |||||||
| 2371 | 8 | 15 | $router->{radius_attributes} ||= {}; | ||||
| 2372 | } | ||||||
| 2373 | else { | ||||||
| 2374 | 439 | 732 | $router->{radius_attributes} | ||||
| 2375 | and err_msg "Attribute 'radius_attributes' is not allowed", | ||||||
| 2376 | " for $name"; | ||||||
| 2377 | } | ||||||
| 2378 | 447 | 757 | if ($model->{no_crypto_filter}) { | ||||
| 2379 | 256 | 514 | $router->{no_crypto_filter} = 1; | ||||
| 2380 | } | ||||||
| 2381 | } | ||||||
| 2382 | |||||||
| 2383 | # Unmanaged device. | ||||||
| 2384 | else { | ||||||
| 2385 | 203 | 174 | my $bridged; | ||||
| 2386 | 203 | 392 | if (delete $router->{owner}) { | ||||
| 2387 | 0 | 0 | warn_msg("Ignoring attribute 'owner' at unmanaged $name"); | ||||
| 2388 | } | ||||||
| 2389 | 203 203 | 173 270 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 2390 | 496 | 689 | if ($interface->{hub}) { | ||||
| 2391 | 0 | 0 | error_atline("Interface with attribute 'hub' must only be", | ||||
| 2392 | " used at managed device"); | ||||||
| 2393 | } | ||||||
| 2394 | 496 | 712 | if (delete $interface->{reroute_permit}) { | ||||
| 2395 | 0 | 0 | warn_msg("Ignoring attribute 'reroute_permit'", | ||||
| 2396 | " at unmanaged $interface->{name}"); | ||||||
| 2397 | } | ||||||
| 2398 | 496 | 900 | if ($interface->{ip} eq 'bridged') { | ||||
| 2399 | 0 | 0 | $bridged = 1; | ||||
| 2400 | } | ||||||
| 2401 | } | ||||||
| 2402 | |||||||
| 2403 | # Unmanaged bridge would complicate generation of static routes. | ||||||
| 2404 | 203 | 351 | if ($bridged) { | ||||
| 2405 | 0 | 0 | error_atline("Bridged interfaces must only be used", | ||||
| 2406 | " at managed device"); | ||||||
| 2407 | } | ||||||
| 2408 | } | ||||||
| 2409 | |||||||
| 2410 | 650 | 532 | my @move_locked; | ||||
| 2411 | |||||||
| 2412 | 650 650 | 528 838 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 2413 | |||||||
| 2414 | # Automatically create a network for loopback interface. | ||||||
| 2415 | 1588 | 2960 | if ($interface->{loopback}) { | ||||
| 2416 | 39 | 31 | my $name; | ||||
| 2417 | my $net_name; | ||||||
| 2418 | |||||||
| 2419 | # Special handling needed for virtual loopback interfaces. | ||||||
| 2420 | # The created network needs to be shared among a group of | ||||||
| 2421 | # interfaces. | ||||||
| 2422 | 39 | 57 | if ($interface->{redundant}) { | ||||
| 2423 | |||||||
| 2424 | # Shared virtual loopback network gets name | ||||||
| 2425 | # 'virtual:netname'. Don't use standard name to prevent | ||||||
| 2426 | # network from getting referenced from rules. | ||||||
| 2427 | 4 | 7 | $net_name = "virtual:$interface->{network}"; | ||||
| 2428 | 4 | 5 | $name = "network:$net_name"; | ||||
| 2429 | } | ||||||
| 2430 | else { | ||||||
| 2431 | |||||||
| 2432 | # Single loopback network needs not to get an unique name. | ||||||
| 2433 | # Take an invalid name 'router.loopback' to prevent name | ||||||
| 2434 | # clashes with real networks or other loopback networks. | ||||||
| 2435 | 35 | 40 | $name = $interface->{name}; | ||||
| 2436 | 35 | 130 | ($net_name = $name) =~ s/^interface://; | ||||
| 2437 | } | ||||||
| 2438 | 39 | 90 | if (not $networks{$net_name}) { | ||||
| 2439 | 37 | 101 | my $network = new( | ||||
| 2440 | 'Network', | ||||||
| 2441 | name => $name, | ||||||
| 2442 | ip => $interface->{ip}, | ||||||
| 2443 | mask => 0xffffffff, | ||||||
| 2444 | |||||||
| 2445 | # Mark as automatically created. | ||||||
| 2446 | loopback => 1, | ||||||
| 2447 | subnet_of => delete $interface->{subnet_of}, | ||||||
| 2448 | is_layer3 => $interface->{is_layer3}, | ||||||
| 2449 | ); | ||||||
| 2450 | 37 | 77 | if (my $private = $interface->{private}) { | ||||
| 2451 | 0 | 0 | $network->{private} = $private; | ||||
| 2452 | } | ||||||
| 2453 | 37 | 56 | $networks{$net_name} = $network; | ||||
| 2454 | } | ||||||
| 2455 | 39 | 50 | $interface->{network} = $net_name; | ||||
| 2456 | } | ||||||
| 2457 | |||||||
| 2458 | # Generate tunnel interface. | ||||||
| 2459 | elsif (my $crypto = $interface->{spoke}) { | ||||||
| 2460 | 25 | 225 | my $net_name = "tunnel:$rname"; | ||||
| 2461 | 25 | 40 | my $iname = "$rname.$net_name"; | ||||
| 2462 | 25 | 64 | my $tunnel_intf = new( | ||||
| 2463 | 'Interface', | ||||||
| 2464 | name => "interface:$iname", | ||||||
| 2465 | ip => 'tunnel', | ||||||
| 2466 | router => $router, | ||||||
| 2467 | network => $net_name, | ||||||
| 2468 | real_interface => $interface | ||||||
| 2469 | ); | ||||||
| 2470 | 25 | 36 | for my $key (qw(hardware routing private bind_nat id)) { | ||||
| 2471 | 125 | 193 | if ($interface->{$key}) { | ||||
| 2472 | 14 | 27 | $tunnel_intf->{$key} = $interface->{$key}; | ||||
| 2473 | } | ||||||
| 2474 | } | ||||||
| 2475 | 25 | 57 | if ($interfaces{$iname}) { | ||||
| 2476 | 0 | 0 | error_atline("Redefining $tunnel_intf->{name}"); | ||||
| 2477 | } | ||||||
| 2478 | 25 | 39 | $interfaces{$iname} = $tunnel_intf; | ||||
| 2479 | 25 25 | 18 34 | push @{ $router->{interfaces} }, $tunnel_intf; | ||||
| 2480 | |||||||
| 2481 | # Create tunnel network. | ||||||
| 2482 | 25 | 51 | my $tunnel_net = new( | ||||
| 2483 | 'Network', | ||||||
| 2484 | name => "network:$net_name", | ||||||
| 2485 | ip => 'tunnel' | ||||||
| 2486 | ); | ||||||
| 2487 | 25 | 44 | if (my $private = $interface->{private}) { | ||||
| 2488 | 0 | 0 | $tunnel_net->{private} = $private; | ||||
| 2489 | } | ||||||
| 2490 | 25 | 40 | $networks{$net_name} = $tunnel_net; | ||||
| 2491 | |||||||
| 2492 | # Tunnel network will later be attached to crypto hub. | ||||||
| 2493 | 25 25 | 18 47 | push @{ $crypto2spokes{$crypto} }, $tunnel_net; | ||||
| 2494 | } | ||||||
| 2495 | |||||||
| 2496 | 1588 | 5687 | if (($interface->{spoke} || $interface->{hub}) && | ||||
| 2497 | !$interface->{no_check}) | ||||||
| 2498 | { | ||||||
| 2499 | 40 | 61 | push @move_locked, $interface; | ||||
| 2500 | } | ||||||
| 2501 | } | ||||||
| 2502 | |||||||
| 2503 | 650 | 1128 | move_locked_interfaces(\@move_locked) if @move_locked; | ||||
| 2504 | |||||||
| 2505 | 650 | 1015 | return $router; | ||||
| 2506 | } | ||||||
| 2507 | |||||||
| 2508 | # No traffic must traverse crypto or secondary interface. | ||||||
| 2509 | # Hence split router into separate instances, one instance for each | ||||||
| 2510 | # crypto/secondary interface. | ||||||
| 2511 | # Splitted routers are tied by identical attribute {device_name}. | ||||||
| 2512 | sub move_locked_interfaces { | ||||||
| 2513 | 39 | 0 | 37 | my ($interfaces) = @_; | |||
| 2514 | 39 | 45 | for my $interface (@$interfaces) { | ||||
| 2515 | 40 | 35 | my $orig_router = $interface->{router}; | ||||
| 2516 | 40 | 39 | my $name = $orig_router->{name}; | ||||
| 2517 | 40 | 127 | my $new_router = new('Router', | ||||
| 2518 | %$orig_router, | ||||||
| 2519 | orig_router => $orig_router, | ||||||
| 2520 | interfaces => [ $interface ]); | ||||||
| 2521 | 40 | 56 | $interface->{router} = $new_router; | ||||
| 2522 | 40 | 35 | push @router_fragments, $new_router; | ||||
| 2523 | |||||||
| 2524 | # Don't check fragment for reachability. | ||||||
| 2525 | 40 | 45 | delete $new_router->{policy_distribution_point}; | ||||
| 2526 | |||||||
| 2527 | # Remove interface from old router. | ||||||
| 2528 | # Retain copy of original interfaces. | ||||||
| 2529 | 40 | 36 | my $interfaces = $orig_router->{interfaces}; | ||||
| 2530 | 40 | 138 | $orig_router->{orig_interfaces} ||= [ @$interfaces ]; | ||||
| 2531 | 40 | 60 | aref_delete($interfaces, $interface); | ||||
| 2532 | |||||||
| 2533 | 40 | 441 | if ($orig_router->{managed}) { | ||||
| 2534 | 18 | 20 | my $hardware = $interface->{hardware}; | ||||
| 2535 | 18 | 25 | $new_router->{hardware} = [ $hardware ]; | ||||
| 2536 | 18 | 22 | my $hw_list = $orig_router->{hardware}; | ||||
| 2537 | |||||||
| 2538 | # Retain copy of original hardware. | ||||||
| 2539 | 18 | 30 | $orig_router->{orig_hardware} = [ @$hw_list ]; | ||||
| 2540 | 18 | 24 | aref_delete($hw_list, $hardware); | ||||
| 2541 | 18 18 | 15 41 | 1 == @{ $hardware->{interfaces} } or | ||||
| 2542 | err_msg("Crypto $interface->{name} must not share hardware", | ||||||
| 2543 | " with other interfaces"); | ||||||
| 2544 | 18 | 46 | if (my $hash = $orig_router->{radius_attributes}) { | ||||
| 2545 | |||||||
| 2546 | # Copy hash, because it is changed per device later. | ||||||
| 2547 | 6 | 25 | $new_router->{radius_attributes} = { %$hash }; | ||||
| 2548 | } | ||||||
| 2549 | } | ||||||
| 2550 | } | ||||||
| 2551 | 39 | 43 | return; | ||||
| 2552 | } | ||||||
| 2553 | |||||||
| 2554 | our %aggregates; | ||||||
| 2555 | |||||||
| 2556 | sub read_aggregate { | ||||||
| 2557 | 52 | 0 | 65 | my $name = shift; | |||
| 2558 | 52 | 92 | my $aggregate = new('Network', name => $name, is_aggregate => 1); | ||||
| 2559 | 52 | 106 | $aggregate->{private} = $private if $private; | ||||
| 2560 | 52 | 74 | skip '='; | ||||
| 2561 | 52 | 84 | skip '\{'; | ||||
| 2562 | 52 | 83 | add_description($aggregate); | ||||
| 2563 | 52 | 53 | while (1) { | ||||
| 2564 | 145 | 176 | last if check '\}'; | ||||
| 2565 | 93 | 175 | if (my ($ip, $mask) = check_assign 'ip', \&read_ip_prefix) { | ||||
| 2566 | 23 | 36 | add_attribute($aggregate, ip => $ip); | ||||
| 2567 | 23 | 29 | add_attribute($aggregate, mask => $mask); | ||||
| 2568 | } | ||||||
| 2569 | elsif (my $owner = check_assign 'owner', \&read_identifier) { | ||||||
| 2570 | 10 | 22 | add_attribute($aggregate, owner => $owner); | ||||
| 2571 | } | ||||||
| 2572 | elsif (my $link = check_assign 'link', \&read_typed_name) { | ||||||
| 2573 | 52 | 89 | add_attribute($aggregate, link => $link); | ||||
| 2574 | } | ||||||
| 2575 | elsif (check_flag 'has_unenforceable') { | ||||||
| 2576 | 2 | 8 | $aggregate->{has_unenforceable} = 1; | ||||
| 2577 | } | ||||||
| 2578 | elsif (my $nat_name = check_nat_name()) { | ||||||
| 2579 | 6 | 15 | my $nat = read_nat("nat:$nat_name"); | ||||
| 2580 | 6 | 12 | $nat->{dynamic} or error_atline("$nat->{name} must be dynamic"); | ||||
| 2581 | 6 | 14 | $aggregate->{nat}->{$nat_name} | ||||
| 2582 | and error_atline("Duplicate NAT definition"); | ||||||
| 2583 | 6 | 13 | $aggregate->{nat}->{$nat_name} = $nat; | ||||
| 2584 | } | ||||||
| 2585 | else { | ||||||
| 2586 | 0 | 0 | syntax_err("Expected some valid attribute"); | ||||
| 2587 | } | ||||||
| 2588 | } | ||||||
| 2589 | 52 | 132 | $aggregate->{link} or err_msg("Attribute 'link' must be defined for $name"); | ||||
| 2590 | 52 | 66 | my $ip = $aggregate->{ip}; | ||||
| 2591 | 52 | 49 | my $mask = $aggregate->{mask}; | ||||
| 2592 | 52 | 85 | if ($ip) { | ||||
| 2593 | 21 | 59 | for my $key (keys %$aggregate) { | ||||
| 2594 | 107 749 | 96 942 | next if grep({ $key eq $_ } | ||||
| 2595 | qw( name ip mask link is_aggregate private nat)); | ||||||
| 2596 | 0 | 0 | error_atline("Must not use attribute $key if mask is set"); | ||||
| 2597 | } | ||||||
| 2598 | } | ||||||
| 2599 | else { | ||||||
| 2600 | 31 | 50 | $aggregate->{ip} = $aggregate->{mask} = 0; | ||||
| 2601 | } | ||||||
| 2602 | 52 | 76 | return $aggregate; | ||||
| 2603 | } | ||||||
| 2604 | |||||||
| 2605 | sub check_router_attributes { | ||||||
| 2606 | 13 | 0 | 15 | my ($parent) = @_; | |||
| 2607 | |||||||
| 2608 | # Add name for error messages. | ||||||
| 2609 | 13 | 35 | my $result = { name => "router_attributes of $parent" }; | ||||
| 2610 | 13 | 18 | check 'router_attributes' or return; | ||||
| 2611 | 7 | 10 | skip '='; | ||||
| 2612 | 7 | 9 | skip '\{'; | ||||
| 2613 | 7 | 8 | while (1) { | ||||
| 2614 | 14 | 19 | last if check '\}'; | ||||
| 2615 | 7 | 14 | if (my $owner = check_assign 'owner', \&read_identifier) { | ||||
| 2616 | 1 | 2 | add_attribute($result, owner => $owner); | ||||
| 2617 | } | ||||||
| 2618 | elsif (my $pair = check_assign('policy_distribution_point', | ||||||
| 2619 | \&read_typed_name)) | ||||||
| 2620 | { | ||||||
| 2621 | 2 | 3 | add_attribute($result, policy_distribution_point => $pair); | ||||
| 2622 | } | ||||||
| 2623 | elsif (my @list = check_assign_list('general_permit', | ||||||
| 2624 | \&read_typed_name_or_simple_protocol)) | ||||||
| 2625 | { | ||||||
| 2626 | 4 | 6 | add_attribute($result, general_permit => \@list); | ||||
| 2627 | } | ||||||
| 2628 | else { | ||||||
| 2629 | 0 | 0 | syntax_err("Unexpected attribute"); | ||||
| 2630 | } | ||||||
| 2631 | } | ||||||
| 2632 | 7 | 16 | return $result; | ||||
| 2633 | } | ||||||
| 2634 | |||||||
| 2635 | our %areas; | ||||||
| 2636 | |||||||
| 2637 | sub read_area { | ||||||
| 2638 | 66 | 0 | 71 | my $name = shift; | |||
| 2639 | 66 | 111 | my $area = new('Area', name => $name); | ||||
| 2640 | 66 | 93 | skip '='; | ||||
| 2641 | 66 | 159 | skip '\{'; | ||||
| 2642 | 66 | 112 | add_description($area); | ||||
| 2643 | 66 | 67 | while (1) { | ||||
| 2644 | 176 | 213 | last if check '\}'; | ||||
| 2645 | 110 | 212 | if (my @elements = check_assign_list('border', \&read_intersection)) { | ||||
| 2646 | 40 44 | 49 239 | if (grep { $_->[0] ne 'interface' || ref $_->[1] } @elements) { | ||||
| 2647 | 0 | 0 | error_atline "Must only use interface names in border"; | ||||
| 2648 | 0 | 0 | @elements = (); | ||||
| 2649 | } | ||||||
| 2650 | 40 | 63 | add_attribute($area, border => \@elements); | ||||
| 2651 | } | ||||||
| 2652 | elsif (@elements = | ||||||
| 2653 | check_assign_list('inclusive_border', \&read_intersection)) | ||||||
| 2654 | { | ||||||
| 2655 | 12 18 | 17 146 | if (grep { $_->[0] ne 'interface' || ref $_->[1] } @elements) { | ||||
| 2656 | 0 | 0 | error_atline "Must only use interface names in border"; | ||||
| 2657 | 0 | 0 | @elements = (); | ||||
| 2658 | } | ||||||
| 2659 | 12 | 23 | add_attribute($area, inclusive_border => \@elements); | ||||
| 2660 | } | ||||||
| 2661 | elsif (check_flag 'auto_border') { | ||||||
| 2662 | 2 | 4 | $area->{auto_border} = 1; | ||||
| 2663 | } | ||||||
| 2664 | elsif (my $pair = check_assign 'anchor', \&read_typed_name) { | ||||||
| 2665 | 17 | 86 | if ($pair->[0] ne 'network' || ref $pair->[1]) { | ||||
| 2666 | 0 | 0 | error_atline "Must only use network name in 'anchor'"; | ||||
| 2667 | 0 | 0 | $pair = undef; | ||||
| 2668 | } | ||||||
| 2669 | 17 | 37 | add_attribute($area, anchor => $pair); | ||||
| 2670 | } | ||||||
| 2671 | elsif (my $owner = check_assign 'owner', \&read_identifier) { | ||||||
| 2672 | 26 | 41 | add_attribute($area, owner => $owner); | ||||
| 2673 | } | ||||||
| 2674 | elsif (my $router_attributes = check_router_attributes($name)) { | ||||||
| 2675 | 7 | 11 | add_attribute($area, router_attributes => $router_attributes); | ||||
| 2676 | } | ||||||
| 2677 | elsif (my $nat_name = check_nat_name()) { | ||||||
| 2678 | 6 | 13 | my $nat = read_nat("nat:$nat_name"); | ||||
| 2679 | 6 | 13 | $nat->{dynamic} or error_atline("$nat->{name} must be dynamic"); | ||||
| 2680 | 6 | 15 | $area->{nat}->{$nat_name} | ||||
| 2681 | and error_atline("Duplicate NAT definition"); | ||||||
| 2682 | 6 | 14 | $area->{nat}->{$nat_name} = $nat; | ||||
| 2683 | } | ||||||
| 2684 | else { | ||||||
| 2685 | 0 | 0 | syntax_err("Expected some valid attribute"); | ||||
| 2686 | } | ||||||
| 2687 | } | ||||||
| 2688 | 66 | 364 | (($area->{border} || $area->{inclusive_border}) && $area->{anchor}) | ||||
| 2689 | and err_msg("Attribute 'anchor' must not be defined together with", | ||||||
| 2690 | " 'border' or 'inclusive_border' for $name"); | ||||||
| 2691 | 66 | 251 | ($area->{anchor} || $area->{border} || $area->{inclusive_border}) | ||||
| 2692 | or err_msg("At least one of attributes 'border', 'inclusive_border'", | ||||||
| 2693 | " or 'anchor' must be defined for $name"); | ||||||
| 2694 | 66 | 82 | return $area; | ||||
| 2695 | } | ||||||
| 2696 | |||||||
| 2697 | our %groups; | ||||||
| 2698 | |||||||
| 2699 | sub read_group { | ||||||
| 2700 | 9 | 0 | 12 | my $name = shift; | |||
| 2701 | 9 | 18 | skip '='; | ||||
| 2702 | 9 | 19 | my $group = new('Group', name => $name); | ||||
| 2703 | 9 | 21 | $group->{private} = $private if $private; | ||||
| 2704 | 9 | 16 | add_description($group); | ||||
| 2705 | 9 | 20 | my @elements = read_list_or_null \&read_intersection; | ||||
| 2706 | 9 | 373 | $group->{elements} = \@elements; | ||||
| 2707 | 9 | 15 | return $group; | ||||
| 2708 | } | ||||||
| 2709 | |||||||
| 2710 | our %protocolgroups; | ||||||
| 2711 | |||||||
| 2712 | sub read_protocolgroup { | ||||||
| 2713 | 2 | 0 | 3 | my $name = shift; | |||
| 2714 | 2 | 2 | skip '='; | ||||
| 2715 | 2 | 5 | my @pairs = read_list_or_null \&read_typed_name_or_simple_protocol; | ||||
| 2716 | 2 | 4 | return new('Protocolgroup', name => $name, elements => \@pairs); | ||||
| 2717 | } | ||||||
| 2718 | |||||||
| 2719 | sub read_port_range { | ||||||
| 2720 | 286 | 0 | 337 | if (defined(my $port1 = check_int)) { | |||
| 2721 | 267 | 504 | error_atline("Too large port number $port1") if $port1 > 65535; | ||||
| 2722 | 267 | 391 | error_atline("Invalid port number '0'") if $port1 == 0; | ||||
| 2723 | 267 | 341 | if (check '-') { | ||||
| 2724 | 21 | 29 | if (defined(my $port2 = check_int)) { | ||||
| 2725 | 21 | 42 | error_atline("Too large port number $port2") if $port2 > 65535; | ||||
| 2726 | 21 | 36 | error_atline("Invalid port number '0'") if $port2 == 0; | ||||
| 2727 | 21 | 34 | error_atline("Invalid port range $port1-$port2") | ||||
| 2728 | if $port1 > $port2; | ||||||
| 2729 | 21 | 46 | if ($port1 == 1 && $port2 == 65535) { | ||||
| 2730 | 3 | 5 | return $aref_tcp_any; | ||||
| 2731 | } | ||||||
| 2732 | else { | ||||||
| 2733 | 18 | 43 | return [ $port1, $port2 ]; | ||||
| 2734 | } | ||||||
| 2735 | } | ||||||
| 2736 | else { | ||||||
| 2737 | 0 | 0 | syntax_err("Missing second port in port range"); | ||||
| 2738 | } | ||||||
| 2739 | } | ||||||
| 2740 | else { | ||||||
| 2741 | 246 | 558 | return [ $port1, $port1 ]; | ||||
| 2742 | } | ||||||
| 2743 | } | ||||||
| 2744 | else { | ||||||
| 2745 | 19 | 27 | return $aref_tcp_any; | ||||
| 2746 | } | ||||||
| 2747 | } | ||||||
| 2748 | |||||||
| 2749 | sub read_port_ranges { | ||||||
| 2750 | 278 | 0 | 275 | my ($prt) = @_; | |||
| 2751 | 278 | 369 | my $range = read_port_range; | ||||
| 2752 | 278 | 415 | if (check ':') { | ||||
| 2753 | 8 | 24 | if ($range ne $aref_tcp_any) { | ||||
| 2754 | 7 | 10 | $prt->{src_range} = $range; | ||||
| 2755 | } | ||||||
| 2756 | 8 | 11 | $prt->{dst_range} = read_port_range; | ||||
| 2757 | } | ||||||
| 2758 | else { | ||||||
| 2759 | 270 | 576 | $prt->{dst_range} = $range; | ||||
| 2760 | } | ||||||
| 2761 | 278 | 351 | return; | ||||
| 2762 | } | ||||||
| 2763 | |||||||
| 2764 | sub read_icmp_type_code { | ||||||
| 2765 | 37 | 0 | 42 | my ($prt) = @_; | |||
| 2766 | 37 | 48 | if (defined(my $type = check_int)) { | ||||
| 2767 | 30 | 63 | error_atline("Too large ICMP type $type") if $type > 255; | ||||
| 2768 | 30 | 42 | if (check '/') { | ||||
| 2769 | 0 | 0 | if (defined(my $code = check_int)) { | ||||
| 2770 | 0 | 0 | error_atline("Too large ICMP code $code") if $code > 255; | ||||
| 2771 | 0 | 0 | $prt->{type} = $type; | ||||
| 2772 | 0 | 0 | $prt->{code} = $code; | ||||
| 2773 | } | ||||||
| 2774 | else { | ||||||
| 2775 | 0 | 0 | syntax_err("Expected ICMP code"); | ||||
| 2776 | } | ||||||
| 2777 | } | ||||||
| 2778 | else { | ||||||
| 2779 | 30 | 49 | $prt->{type} = $type; | ||||
| 2780 | 30 | 158 | if ($type == 0 || $type == 3 || $type == 11) { | ||||
| 2781 | 12 | 22 | $prt->{flags}->{stateless_icmp} = 1; | ||||
| 2782 | } | ||||||
| 2783 | } | ||||||
| 2784 | } | ||||||
| 2785 | else { | ||||||
| 2786 | |||||||
| 2787 | # No type and code given. | ||||||
| 2788 | } | ||||||
| 2789 | 37 | 48 | return; | ||||
| 2790 | } | ||||||
| 2791 | |||||||
| 2792 | sub read_proto_nr { | ||||||
| 2793 | 1 | 0 | 1 | my ($prt) = @_; | |||
| 2794 | 1 | 2 | if (defined(my $nr = check_int)) { | ||||
| 2795 | 1 | 2 | error_atline("Too large protocol number $nr") if $nr > 255; | ||||
| 2796 | 1 | 3 | error_atline("Invalid protocol number '0'") if $nr == 0; | ||||
| 2797 | 1 | 4 | if ($nr == 1) { | ||||
| 2798 | 0 | 0 | $prt->{proto} = 'icmp'; | ||||
| 2799 | |||||||
| 2800 | # No ICMP type and code given. | ||||||
| 2801 | } | ||||||
| 2802 | elsif ($nr == 4) { | ||||||
| 2803 | 0 | 0 | $prt->{proto} = 'tcp'; | ||||
| 2804 | 0 | 0 | $prt->{dst_range} = $aref_tcp_any; | ||||
| 2805 | } | ||||||
| 2806 | elsif ($nr == 17) { | ||||||
| 2807 | 0 | 0 | $prt->{proto} = 'udp'; | ||||
| 2808 | 0 | 0 | $prt->{dst_range} = $aref_tcp_any; | ||||
| 2809 | } | ||||||
| 2810 | else { | ||||||
| 2811 | 1 | 2 | $prt->{proto} = $nr; | ||||
| 2812 | } | ||||||
| 2813 | } | ||||||
| 2814 | else { | ||||||
| 2815 | 0 | 0 | syntax_err("Expected protocol number"); | ||||
| 2816 | } | ||||||
| 2817 | 1 | 2 | return; | ||||
| 2818 | } | ||||||
| 2819 | |||||||
| 2820 | sub gen_protocol_name { | ||||||
| 2821 | 317 | 0 | 284 | my ($protocol) = @_; | |||
| 2822 | 317 | 351 | my $proto = $protocol->{proto}; | ||||
| 2823 | 317 | 284 | my $name = $proto; | ||||
| 2824 | |||||||
| 2825 | 317 | 914 | if ($proto eq 'ip') { | ||||
| 2826 | } | ||||||
| 2827 | elsif ($proto eq 'tcp' or $proto eq 'udp') { | ||||||
| 2828 | my $port_name = sub { | ||||||
| 2829 | 262 | 393 | my ($v1, $v2) = @_; | ||||
| 2830 | 262 | 451 | if ($v1 == $v2) { | ||||
| 2831 | 228 | 371 | return ($v1); | ||||
| 2832 | } | ||||||
| 2833 | elsif ($v1 == 1 and $v2 == 65535) { | ||||||
| 2834 | 19 | 30 | return (''); | ||||
| 2835 | } | ||||||
| 2836 | else { | ||||||
| 2837 | 15 | 36 | return ("$v1-$v2"); | ||||
| 2838 | } | ||||||
| 2839 | 262 | 818 | }; | ||||
| 2840 | 262 | 293 | my $src_range = $protocol->{src_range}; | ||||
| 2841 | 262 | 606 | my $src_port = $src_range && $port_name->(@$src_range); | ||||
| 2842 | 262 262 | 246 480 | my $dst_port = $port_name->(@{ $protocol->{dst_range} }); | ||||
| 2843 | 262 | 249 | my $port; | ||||
| 2844 | 262 | 393 | $port = "$src_port:" if $src_port; | ||||
| 2845 | 262 | 742 | $port .= "$dst_port" if $dst_port; | ||||
| 2846 | 262 | 1167 | $name .= " $port" if $port; | ||||
| 2847 | } | ||||||
| 2848 | elsif ($proto eq 'icmp') { | ||||||
| 2849 | 31 | 66 | if (defined(my $type = $protocol->{type})) { | ||||
| 2850 | 24 | 39 | if (defined(my $code = $protocol->{code})) { | ||||
| 2851 | 0 | 0 | $name = "$proto $type/$code"; | ||||
| 2852 | } | ||||||
| 2853 | else { | ||||||
| 2854 | 24 | 45 | $name = "$proto $type"; | ||||
| 2855 | } | ||||||
| 2856 | } | ||||||
| 2857 | } | ||||||
| 2858 | else { | ||||||
| 2859 | 1 | 2 | $name = "proto $proto"; | ||||
| 2860 | } | ||||||
| 2861 | 317 | 456 | return $name; | ||||
| 2862 | } | ||||||
| 2863 | |||||||
| 2864 | our %protocols; | ||||||
| 2865 | |||||||
| 2866 | sub cache_anonymous_protocol { | ||||||
| 2867 | 317 | 0 | 329 | my ($protocol) = @_; | |||
| 2868 | 317 | 403 | my $name = gen_protocol_name($protocol); | ||||
| 2869 | 317 | 614 | if (my $cached = $protocols{$name}) { | ||||
| 2870 | 25 | 36 | return $cached; | ||||
| 2871 | } | ||||||
| 2872 | else { | ||||||
| 2873 | 292 | 356 | $protocol->{name} = $name; | ||||
| 2874 | 292 | 314 | $protocol->{is_used} = 1; | ||||
| 2875 | 292 | 407 | $protocols{$name} = $protocol; | ||||
| 2876 | 292 | 387 | return $protocol; | ||||
| 2877 | } | ||||||
| 2878 | } | ||||||
| 2879 | |||||||
| 2880 | sub read_simple_protocol { | ||||||
| 2881 | 345 | 0 | 334 | my $name = shift; | |||
| 2882 | 345 | 398 | my $protocol = {}; | ||||
| 2883 | 345 | 618 | my $proto = read_identifier(); | ||||
| 2884 | 345 | 857 | if ($proto eq 'ip') { | ||||
| 2885 | 29 | 47 | $protocol->{proto} = 'ip'; | ||||
| 2886 | } | ||||||
| 2887 | elsif ($proto eq 'tcp') { | ||||||
| 2888 | 264 | 401 | $protocol->{proto} = 'tcp'; | ||||
| 2889 | 264 | 399 | read_port_ranges($protocol); | ||||
| 2890 | } | ||||||
| 2891 | elsif ($proto eq 'udp') { | ||||||
| 2892 | 14 | 25 | $protocol->{proto} = 'udp'; | ||||
| 2893 | 14 | 19 | read_port_ranges $protocol; | ||||
| 2894 | } | ||||||
| 2895 | elsif ($proto eq 'icmp') { | ||||||
| 2896 | 37 | 64 | $protocol->{proto} = 'icmp'; | ||||
| 2897 | 37 | 59 | read_icmp_type_code $protocol; | ||||
| 2898 | } | ||||||
| 2899 | elsif ($proto eq 'proto') { | ||||||
| 2900 | 1 | 3 | read_proto_nr $protocol; | ||||
| 2901 | } | ||||||
| 2902 | else { | ||||||
| 2903 | 0 | 0 | error_atline("Unknown protocol '$proto'"); | ||||
| 2904 | |||||||
| 2905 | # Prevent further errors. | ||||||
| 2906 | 0 | 0 | $protocol->{proto} = 'ip'; | ||||
| 2907 | } | ||||||
| 2908 | 345 | 447 | if ($name) { | ||||
| 2909 | 28 | 43 | $protocol->{name} = $name; | ||||
| 2910 | } | ||||||
| 2911 | else { | ||||||
| 2912 | 317 | 430 | $protocol = cache_anonymous_protocol($protocol); | ||||
| 2913 | } | ||||||
| 2914 | 345 | 824 | return $protocol; | ||||
| 2915 | } | ||||||
| 2916 | |||||||
| 2917 | sub check_protocol_flags { | ||||||
| 2918 | 28 | 0 | 32 | my ($protocol) = @_; | |||
| 2919 | 28 | 40 | while (check ',') { | ||||
| 2920 | 7 | 11 | my $flag = read_identifier; | ||||
| 2921 | 7 | 34 | if ($flag =~ /^(src|dst)_(net|any)$/) { | ||||
| 2922 | 3 | 13 | $protocol->{flags}->{$1}->{$2} = 1; | ||||
| 2923 | } | ||||||
| 2924 | elsif ($flag =~ | ||||||
| 2925 | /^(?:stateless|reversed|oneway|overlaps|no_check_supernet_rules)/) | ||||||
| 2926 | { | ||||||
| 2927 | 4 | 11 | $protocol->{flags}->{$flag} = 1; | ||||
| 2928 | } | ||||||
| 2929 | else { | ||||||
| 2930 | 0 | 0 | syntax_err("Unknown flag '$flag'"); | ||||
| 2931 | } | ||||||
| 2932 | } | ||||||
| 2933 | 28 | 31 | return; | ||||
| 2934 | } | ||||||
| 2935 | |||||||
| 2936 | sub read_typed_name_or_simple_protocol { | ||||||
| 2937 | 350 | 0 | 430 | return (check_typed_name() || read_simple_protocol()); | |||
| 2938 | } | ||||||
| 2939 | |||||||
| 2940 | sub read_protocol { | ||||||
| 2941 | 28 | 0 | 35 | my $name = shift; | |||
| 2942 | 28 | 37 | skip '='; | ||||
| 2943 | 28 | 53 | my $protocol = read_simple_protocol($name); | ||||
| 2944 | 28 | 47 | check_protocol_flags($protocol); | ||||
| 2945 | 28 | 40 | skip ';'; | ||||
| 2946 | 28 | 39 | return $protocol; | ||||
| 2947 | } | ||||||
| 2948 | |||||||
| 2949 | our %services; | ||||||
| 2950 | |||||||
| 2951 | sub assign_union_allow_user { | ||||||
| 2952 | 622 | 0 | 624 | my ($name) = @_; | |||
| 2953 | 622 | 701 | skip $name; | ||||
| 2954 | 622 | 876 | skip '='; | ||||
| 2955 | 622 | 1065 | local $user_object->{active} = 1; | ||||
| 2956 | 622 | 619 | $user_object->{refcount} = 0; | ||||
| 2957 | 622 | 813 | my @result = read_union ';'; | ||||
| 2958 | 622 | 1354 | return \@result, $user_object->{refcount}; | ||||
| 2959 | } | ||||||
| 2960 | |||||||
| 2961 | sub read_service { | ||||||
| 2962 | 274 | 0 | 313 | my ($name) = @_; | |||
| 2963 | 274 | 608 | my $service = { name => $name, rules => [] }; | ||||
| 2964 | 274 | 473 | $service->{private} = $private if $private; | ||||
| 2965 | 274 | 354 | skip '='; | ||||
| 2966 | 274 | 402 | skip '\{'; | ||||
| 2967 | 274 | 429 | add_description($service); | ||||
| 2968 | 274 | 268 | while (1) { | ||||
| 2969 | 282 | 367 | last if check 'user'; | ||||
| 2970 | 8 | 19 | if (my $sub_owner = check_assign 'sub_owner', \&read_identifier) { | ||||
| 2971 | 1 | 2 | add_attribute($service, sub_owner => $sub_owner); | ||||
| 2972 | } | ||||||
| 2973 | elsif (my @other = check_assign_list 'overlaps', \&read_typed_name) { | ||||||
| 2974 | 4 | 7 | add_attribute($service, overlaps => \@other); | ||||
| 2975 | } | ||||||
| 2976 | elsif (my $visible = check_assign('visible', \&read_owner_pattern)) { | ||||||
| 2977 | 0 | 0 | add_attribute($service, visible => $visible); | ||||
| 2978 | } | ||||||
| 2979 | elsif (check_flag('multi_owner')) { | ||||||
| 2980 | 1 | 2 | $service->{multi_owner} = 1; | ||||
| 2981 | } | ||||||
| 2982 | elsif (check_flag('unknown_owner')) { | ||||||
| 2983 | 0 | 0 | $service->{unknown_owner} = 1; | ||||
| 2984 | } | ||||||
| 2985 | elsif (check_flag('has_unenforceable')) { | ||||||
| 2986 | 2 | 4 | $service->{has_unenforceable} = 1; | ||||
| 2987 | } | ||||||
| 2988 | elsif (check_flag('disabled')) { | ||||||
| 2989 | 0 | 0 | $service->{disabled} = 1; | ||||
| 2990 | } | ||||||
| 2991 | else { | ||||||
| 2992 | 0 | 0 | syntax_err("Expected some valid attribute or definition of 'user'"); | ||||
| 2993 | } | ||||||
| 2994 | } | ||||||
| 2995 | |||||||
| 2996 | # 'user' has already been read above. | ||||||
| 2997 | 274 | 417 | skip '='; | ||||
| 2998 | 274 | 402 | if (check 'foreach') { | ||||
| 2999 | 0 | 0 | $service->{foreach} = 1; | ||||
| 3000 | } | ||||||
| 3001 | 274 | 504 | my @elements = read_list \&read_intersection; | ||||
| 3002 | 274 | 456 | $service->{user} = \@elements; | ||||
| 3003 | |||||||
| 3004 | 274 | 429 | while (1) { | ||||
| 3005 | 585 | 742 | last if check '\}'; | ||||
| 3006 | 311 | 693 | if (my $action = check_permit_deny) { | ||||
| 3007 | 311 | 451 | my ($src, $src_user) = assign_union_allow_user 'src'; | ||||
| 3008 | 311 | 435 | my ($dst, $dst_user) = assign_union_allow_user 'dst'; | ||||
| 3009 | 311 | 946 | my $prt = [ | ||||
| 3010 | read_assign_list( | ||||||
| 3011 | 'prt', \&read_typed_name_or_simple_protocol | ||||||
| 3012 | ) | ||||||
| 3013 | ]; | ||||||
| 3014 | 311 | 316 | my $log; | ||||
| 3015 | 311 | 551 | if (my @list = check_assign_list('log', \&read_identifier)) { | ||||
| 3016 | 18 | 20 | $log = \@list; | ||||
| 3017 | } | ||||||
| 3018 | $src_user | ||||||
| 3019 | 311 | 709 | or $dst_user | ||||
| 3020 | or error_atline("Rule must use keyword 'user'"); | ||||||
| 3021 | 311 | 650 | if ($service->{foreach} and not($src_user and $dst_user)) { | ||||
| 3022 | 0 | 0 | warn_msg("Rule of $name should reference 'user'", | ||||
| 3023 | " in 'src' and 'dst'\n", | ||||||
| 3024 | " because service has keyword 'foreach'"); | ||||||
| 3025 | } | ||||||
| 3026 | 311 | 1262 | my $rule = { | ||||
| 3027 | service => $service, | ||||||
| 3028 | action => $action, | ||||||
| 3029 | src => $src, | ||||||
| 3030 | dst => $dst, | ||||||
| 3031 | prt => $prt, | ||||||
| 3032 | has_user => $src_user ? $dst_user ? 'both' : 'src' : 'dst', | ||||||
| 3033 | }; | ||||||
| 3034 | 311 | 492 | $rule->{log} = $log if $log; | ||||
| 3035 | 311 311 | 257 624 | push @{ $service->{rules} }, $rule; | ||||
| 3036 | } | ||||||
| 3037 | else { | ||||||
| 3038 | 0 | 0 | syntax_err("Expected 'permit' or 'deny'"); | ||||
| 3039 | } | ||||||
| 3040 | } | ||||||
| 3041 | 274 | 408 | return $service; | ||||
| 3042 | } | ||||||
| 3043 | |||||||
| 3044 | our %pathrestrictions; | ||||||
| 3045 | |||||||
| 3046 | sub read_pathrestriction { | ||||||
| 3047 | 29 | 0 | 32 | my $name = shift; | |||
| 3048 | 29 | 41 | skip '='; | ||||
| 3049 | 29 | 46 | my $restriction = new('Pathrestriction', name => $name); | ||||
| 3050 | 29 | 51 | $restriction->{private} = $private if $private; | ||||
| 3051 | 29 | 40 | add_description($restriction); | ||||
| 3052 | 29 | 49 | my @elements = read_list \&read_intersection; | ||||
| 3053 | 29 | 49 | $restriction->{elements} = \@elements; | ||||
| 3054 | 29 | 40 | return $restriction; | ||||
| 3055 | } | ||||||
| 3056 | |||||||
| 3057 | sub read_attributed_object { | ||||||
| 3058 | 40 | 0 | 36 | my ($name, $attr_descr) = @_; | |||
| 3059 | 40 | 69 | my $object = { name => $name }; | ||||
| 3060 | 40 | 56 | skip '='; | ||||
| 3061 | 40 | 58 | skip '\{'; | ||||
| 3062 | 40 | 60 | add_description($object); | ||||
| 3063 | 40 | 39 | while (1) { | ||||
| 3064 | 282 | 333 | last if check '\}'; | ||||
| 3065 | 242 | 333 | my $attribute = read_identifier; | ||||
| 3066 | 242 | 533 | my $val_descr = $attr_descr->{$attribute} | ||||
| 3067 | or syntax_err("Unknown attribute '$attribute'"); | ||||||
| 3068 | 242 | 286 | skip '='; | ||||
| 3069 | 242 | 220 | my $val; | ||||
| 3070 | 242 | 417 | if (my $values = $val_descr->{values}) { | ||||
| 3071 | 174 | 218 | $val = read_identifier; | ||||
| 3072 | 174 1016 | 208 1418 | grep { $_ eq $val } @$values | ||||
| 3073 | or syntax_err("Invalid value"); | ||||||
| 3074 | } | ||||||
| 3075 | elsif (my $fun = $val_descr->{function}) { | ||||||
| 3076 | 68 | 87 | $val = &$fun; | ||||
| 3077 | } | ||||||
| 3078 | else { | ||||||
| 3079 | 0 | 0 | internal_err(); | ||||
| 3080 | } | ||||||
| 3081 | 242 | 287 | skip ';'; | ||||
| 3082 | 242 | 348 | add_attribute($object, $attribute => $val); | ||||
| 3083 | } | ||||||
| 3084 | 40 | 108 | for my $attribute (keys %$attr_descr) { | ||||
| 3085 | 300 | 240 | my $description = $attr_descr->{$attribute}; | ||||
| 3086 | 300 | 416 | unless (defined $object->{$attribute}) { | ||||
| 3087 | 58 | 79 | if (my $default = $description->{default}) { | ||||
| 3088 | 58 | 83 | $object->{$attribute} = $default; | ||||
| 3089 | } | ||||||
| 3090 | else { | ||||||
| 3091 | 0 | 0 | error_atline("Missing '$attribute' for $object->{name}"); | ||||
| 3092 | } | ||||||
| 3093 | } | ||||||
| 3094 | |||||||
| 3095 | # Convert from syntax to internal values, e.g. 'none' => undef. | ||||||
| 3096 | 300 | 456 | if (my $map = $description->{map}) { | ||||
| 3097 | 140 | 129 | my $value = $object->{$attribute}; | ||||
| 3098 | 140 | 258 | if (exists $map->{$value}) { | ||||
| 3099 | 47 | 78 | $object->{$attribute} = $map->{$value}; | ||||
| 3100 | } | ||||||
| 3101 | } | ||||||
| 3102 | } | ||||||
| 3103 | 40 | 76 | return $object; | ||||
| 3104 | } | ||||||
| 3105 | |||||||
| 3106 | my %isakmp_attributes = ( | ||||||
| 3107 | |||||||
| 3108 | # This one is ignored and is optional. | ||||||
| 3109 | identity => { | ||||||
| 3110 | values => [qw( address fqdn )], | ||||||
| 3111 | default => 'none', | ||||||
| 3112 | map => { none => undef } | ||||||
| 3113 | }, | ||||||
| 3114 | nat_traversal => { | ||||||
| 3115 | values => [qw( on additional off )], | ||||||
| 3116 | default => 'off', | ||||||
| 3117 | map => { off => undef } | ||||||
| 3118 | }, | ||||||
| 3119 | authentication => { values => [qw( preshare rsasig )], }, | ||||||
| 3120 | encryption => { values => [qw( aes aes192 aes256 des 3des )], }, | ||||||
| 3121 | hash => { values => [qw( md5 sha sha256 sha384 sha512 )], }, | ||||||
| 3122 | ike_version => { values => [ 1, 2 ], default => 1, }, | ||||||
| 3123 | lifetime => { function => \&read_time_val, }, | ||||||
| 3124 | group => { values => [ 1, 2, 5, 14, 15, 16, 19, 20, 21, 24 ], }, | ||||||
| 3125 | lifetime => { function => \&read_time_val, }, | ||||||
| 3126 | trust_point => { | ||||||
| 3127 | function => \&read_identifier, | ||||||
| 3128 | default => 'none', | ||||||
| 3129 | map => { none => undef } | ||||||
| 3130 | }, | ||||||
| 3131 | ); | ||||||
| 3132 | |||||||
| 3133 | our %isakmp; | ||||||
| 3134 | |||||||
| 3135 | sub read_isakmp { | ||||||
| 3136 | 20 | 0 | 21 | my ($name) = @_; | |||
| 3137 | 20 | 31 | return read_attributed_object $name, \%isakmp_attributes; | ||||
| 3138 | } | ||||||
| 3139 | |||||||
| 3140 | my %ipsec_attributes = ( | ||||||
| 3141 | key_exchange => { function => \&read_typed_name, }, | ||||||
| 3142 | esp_encryption => { | ||||||
| 3143 | values => [qw( none aes aes192 aes256 des 3des )], | ||||||
| 3144 | default => 'none', | ||||||
| 3145 | map => { none => undef } | ||||||
| 3146 | }, | ||||||
| 3147 | esp_authentication => { | ||||||
| 3148 | values => [qw( none md5_hmac sha_hmac md5 sha sha256 sha384 sha512 )], | ||||||
| 3149 | default => 'none', | ||||||
| 3150 | map => { none => undef, | ||||||
| 3151 | |||||||
| 3152 | # Compatibility for old version. | ||||||
| 3153 | md5_hmac => 'md5', sha_hmac => 'sha', } | ||||||
| 3154 | }, | ||||||
| 3155 | ah => { | ||||||
| 3156 | values => [qw( none md5_hmac sha_hmac md5 sha sha256 sha384 sha512 )], | ||||||
| 3157 | default => 'none', | ||||||
| 3158 | map => { none => undef, md5_hmac => 'md5', sha_hmac => 'sha', } | ||||||
| 3159 | }, | ||||||
| 3160 | pfs_group => { | ||||||
| 3161 | values => [qw( none 1 2 5 14 15 16 19 20 21 24 )], | ||||||
| 3162 | default => 'none', | ||||||
| 3163 | map => { none => undef } | ||||||
| 3164 | }, | ||||||
| 3165 | lifetime => { function => \&read_time_val, }, | ||||||
| 3166 | ); | ||||||
| 3167 | |||||||
| 3168 | our %ipsec; | ||||||
| 3169 | |||||||
| 3170 | sub read_ipsec { | ||||||
| 3171 | 20 | 0 | 18 | my ($name) = @_; | |||
| 3172 | 20 | 36 | return read_attributed_object $name, \%ipsec_attributes; | ||||
| 3173 | } | ||||||
| 3174 | |||||||
| 3175 | our %crypto; | ||||||
| 3176 | |||||||
| 3177 | sub read_crypto { | ||||||
| 3178 | 21 | 0 | 20 | my ($name) = @_; | |||
| 3179 | 21 | 27 | skip '='; | ||||
| 3180 | 21 | 32 | skip '\{'; | ||||
| 3181 | 21 | 36 | my $crypto = { name => $name }; | ||||
| 3182 | 21 | 33 | $crypto->{private} = $private if $private; | ||||
| 3183 | 21 | 31 | add_description($crypto); | ||||
| 3184 | 21 | 21 | while (1) { | ||||
| 3185 | 45 | 54 | last if check '\}'; | ||||
| 3186 | 24 | 38 | if (check_flag 'detailed_crypto_acl') { | ||||
| 3187 | 3 | 6 | $crypto->{detailed_crypto_acl} = 1; | ||||
| 3188 | } | ||||||
| 3189 | elsif (my $type = check_assign 'type', \&read_typed_name) { | ||||||
| 3190 | 21 | 41 | $crypto->{type} | ||||
| 3191 | and error_atline("Redefining 'type' attribute"); | ||||||
| 3192 | 21 | 36 | $crypto->{type} = $type; | ||||
| 3193 | } | ||||||
| 3194 | else { | ||||||
| 3195 | 0 | 0 | syntax_err("Expected valid attribute"); | ||||
| 3196 | } | ||||||
| 3197 | } | ||||||
| 3198 | 21 | 42 | $crypto->{type} or error_atline("Missing 'type' for $name"); | ||||
| 3199 | 21 | 23 | return $crypto; | ||||
| 3200 | } | ||||||
| 3201 | |||||||
| 3202 | our %owners; | ||||||
| 3203 | |||||||
| 3204 | sub read_owner { | ||||||
| 3205 | 64 | 0 | 66 | my $name = shift; | |||
| 3206 | 64 | 85 | my $owner = new('Owner', name => $name); | ||||
| 3207 | 64 | 90 | skip '='; | ||||
| 3208 | 64 | 96 | skip '\{'; | ||||
| 3209 | 64 | 105 | add_description($owner); | ||||
| 3210 | 64 | 63 | while (1) { | ||||
| 3211 | 154 | 187 | last if check '\}'; | ||||
| 3212 | 90 | 161 | if (my $alias = check_assign('alias', \&read_string)) { | ||||
| 3213 | 3 | 5 | $owner->{alias} | ||||
| 3214 | and error_atline("Redefining 'alias' attribute"); | ||||||
| 3215 | 3 | 6 | $owner->{alias} = $alias; | ||||
| 3216 | } | ||||||
| 3217 | elsif (my @admins = check_assign_list('admins', \&read_name)) { | ||||||
| 3218 | 59 | 111 | $owner->{admins} | ||||
| 3219 | and error_atline("Redefining 'admins' attribute"); | ||||||
| 3220 | 59 | 116 | $owner->{admins} = \@admins; | ||||
| 3221 | } | ||||||
| 3222 | elsif (my @watchers = check_assign_list('watchers', \&read_name)) { | ||||||
| 3223 | 14 | 28 | if ($from_json->{watchers}) { | ||||
| 3224 | 0 | 0 | error_atline("Watchers must only be defined", | ||||
| 3225 | " in JSON/ directory"); | ||||||
| 3226 | } | ||||||
| 3227 | 14 | 24 | $owner->{watchers} | ||||
| 3228 | and error_atline("Redefining 'watchers' attribute"); | ||||||
| 3229 | 14 | 26 | $owner->{watchers} = \@watchers; | ||||
| 3230 | } | ||||||
| 3231 | elsif (check_flag 'extend_only') { | ||||||
| 3232 | 9 | 17 | $owner->{extend_only} = 1; | ||||
| 3233 | } | ||||||
| 3234 | elsif (check_flag 'extend_unbounded') { | ||||||
| 3235 | 1 | 2 | $owner->{extend_unbounded} = 1; | ||||
| 3236 | } | ||||||
| 3237 | elsif (check_flag 'extend') { | ||||||
| 3238 | 3 | 7 | $owner->{extend} = 1; | ||||
| 3239 | } | ||||||
| 3240 | elsif (check_flag 'show_all') { | ||||||
| 3241 | 1 | 3 | $owner->{show_all} = 1; | ||||
| 3242 | } | ||||||
| 3243 | else { | ||||||
| 3244 | 0 | 0 | syntax_err("Expected valid attribute"); | ||||
| 3245 | } | ||||||
| 3246 | } | ||||||
| 3247 | 64 | 133 | if (!$owner->{admins}) { | ||||
| 3248 | 5 | 19 | $owner->{extend_only} and $owner->{watchers} or | ||||
| 3249 | error_atline("Missing attribute 'admins'"); | ||||||
| 3250 | 5 | 8 | $owner->{admins} = []; | ||||
| 3251 | } | ||||||
| 3252 | 64 | 75 | return $owner; | ||||
| 3253 | } | ||||||
| 3254 | |||||||
| 3255 | my %global_type = ( | ||||||
| 3256 | router => [ \&read_router, \%routers ], | ||||||
| 3257 | network => [ \&read_network, \%networks ], | ||||||
| 3258 | any => [ \&read_aggregate, \%aggregates ], | ||||||
| 3259 | area => [ \&read_area, \%areas ], | ||||||
| 3260 | owner => [ \&read_owner, \%owners ], | ||||||
| 3261 | group => [ \&read_group, \%groups ], | ||||||
| 3262 | protocol => [ \&read_protocol, \%protocols ], | ||||||
| 3263 | protocolgroup => [ \&read_protocolgroup, \%protocolgroups ], | ||||||
| 3264 | service => [ \&read_service, \%services ], | ||||||
| 3265 | pathrestriction => [ \&read_pathrestriction, \%pathrestrictions ], | ||||||
| 3266 | isakmp => [ \&read_isakmp, \%isakmp ], | ||||||
| 3267 | ipsec => [ \&read_ipsec, \%ipsec ], | ||||||
| 3268 | crypto => [ \&read_crypto, \%crypto ], | ||||||
| 3269 | ); | ||||||
| 3270 | |||||||
| 3271 | sub read_netspoc { | ||||||
| 3272 | |||||||
| 3273 | # Check for global definitions. | ||||||
| 3274 | 2288 | 0 | 2677 | my $pair = check_typed_name or syntax_err(''); | |||
| 3275 | 2288 | 3154 | my ($type, $name) = @$pair; | ||||
| 3276 | 2288 | 4421 | my $descr = $global_type{$type} | ||||
| 3277 | or syntax_err("Unknown global definition"); | ||||||
| 3278 | 2288 | 2208 | my ($fun, $hash) = @$descr; | ||||
| 3279 | 2288 | 5661 | my $result = $fun->("$type:$name"); | ||||
| 3280 | 2288 | 3407 | $result->{file} = $current_file; | ||||
| 3281 | 2288 | 4026 | if (my $other = $hash->{$name}) { | ||||
| 3282 | 0 | 0 | err_msg("Duplicate definition of $type:$name in", | ||||
| 3283 | " $current_file and $other->{file}"); | ||||||
| 3284 | } | ||||||
| 3285 | |||||||
| 3286 | # Result is not used in this module but can be useful | ||||||
| 3287 | # when this function is called from outside. | ||||||
| 3288 | 2288 | 6114 | return $hash->{$name} = $result; | ||||
| 3289 | } | ||||||
| 3290 | |||||||
| 3291 | # Read input from file and process it by function which is given as argument. | ||||||
| 3292 | sub read_file { | ||||||
| 3293 | 342 | 0 | 408 | local $current_file = shift; | |||
| 3294 | 342 | 300 | my $read_syntax = shift; | ||||
| 3295 | |||||||
| 3296 | # Read file as one large line. | ||||||
| 3297 | 342 | 796 | local $/; | ||||
| 3298 | 342 | 304 | local $input; | ||||
| 3299 | |||||||
| 3300 | 342 | 510 | if (defined $current_file) { | ||||
| 3301 | 342 | 4043 | open(my $fh, '<', $current_file) | ||||
| 3302 | or fatal_err("Can't open $current_file: $!"); | ||||||
| 3303 | |||||||
| 3304 | # Fill buffer with content of whole file. | ||||||
| 3305 | # Content is implicitly freed when subroutine is left. | ||||||
| 3306 | 342 | 4102 | $input = <$fh>; | ||||
| 3307 | 342 | 1357 | close $fh; | ||||
| 3308 | } | ||||||
| 3309 | else { | ||||||
| 3310 | 0 | 0 | $current_file = 'STDIN'; | ||||
| 3311 | 0 | 0 | $input = <>; | ||||
| 3312 | } | ||||||
| 3313 | 342 | 418 | local $line = 1; | ||||
| 3314 | 342 | 1146 | my $length = length $input; | ||||
| 3315 | 342 | 577 | while (skip_space_and_comment, pos $input != $length) { | ||||
| 3316 | 2288 | 2564 | &$read_syntax; | ||||
| 3317 | } | ||||||
| 3318 | 342 | 1540 | return; | ||||
| 3319 | } | ||||||
| 3320 | |||||||
| 3321 | # Try to read file 'config' in toplevel directory $path. | ||||||
| 3322 | sub read_config { | ||||||
| 3323 | 326 | 0 | 319 | my ($path) = @_; | |||
| 3324 | 326 | 287 | my %result; | ||||
| 3325 | my $read_config_data = sub { | ||||||
| 3326 | 0 | 0 | my $key = read_identifier(); | ||||
| 3327 | 0 | 0 | valid_config_key($key) or syntax_err("Invalid keyword"); | ||||
| 3328 | 0 | 0 | skip('='); | ||||
| 3329 | 0 | 0 | my $val = read_identifier; | ||||
| 3330 | 0 | 0 | if (my $expected = check_config_pair($key, $val)) { | ||||
| 3331 | 0 | 0 | syntax_err("Expected value matching '$expected'"); | ||||
| 3332 | } | ||||||
| 3333 | 0 | 0 | skip(';'); | ||||
| 3334 | 0 | 0 | $result{$key} = $val; | ||||
| 3335 | 326 | 1069 | }; | ||||
| 3336 | |||||||
| 3337 | 326 | 1993 | if (defined $path && -d $path) { | ||||
| 3338 | 305 | 4586 | opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!"); | ||||
| 3339 | 305 919 | 2268 1644 | if (grep { $_ eq 'config' } readdir $dh) { | ||||
| 3340 | 0 | 0 | $path = "$path/config"; | ||||
| 3341 | 0 | 0 | read_file $path, $read_config_data; | ||||
| 3342 | } | ||||||
| 3343 | 305 | 1460 | closedir $dh; | ||||
| 3344 | } | ||||||
| 3345 | 326 | 1444 | return \%result; | ||||
| 3346 | } | ||||||
| 3347 | |||||||
| 3348 | sub read_json_watchers { | ||||||
| 3349 | 0 | 0 | 0 | my ($path) = @_; | |||
| 3350 | 0 | 0 | opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!"); | ||||
| 3351 | 0 0 | 0 0 | my @files = map({ Encode::decode($filename_encode, $_) } readdir $dh); | ||||
| 3352 | 0 | 0 | closedir $dh; | ||||
| 3353 | 0 | 0 | for my $owner_name (@files) { | ||||
| 3354 | 0 | 0 | next if $owner_name =~ /^\./; | ||||
| 3355 | 0 | 0 | next if $owner_name =~ m/$config{ignore_files}/o; | ||||
| 3356 | 0 | 0 | my $path = "$path/$owner_name"; | ||||
| 3357 | 0 | 0 | opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!"); | ||||
| 3358 | 0 0 | 0 0 | my @files = map({ Encode::decode($filename_encode, $_) } readdir $dh); | ||||
| 3359 | 0 | 0 | closedir $dh; | ||||
| 3360 | 0 | 0 | for my $file (@files) { | ||||
| 3361 | 0 | 0 | next if $file =~ /^\./; | ||||
| 3362 | 0 | 0 | next if $file =~ m/$config{ignore_files}/o; | ||||
| 3363 | 0 | 0 | my $path = "$path/$file"; | ||||
| 3364 | 0 | 0 | if ($file ne 'watchers') { | ||||
| 3365 | 0 | 0 | err_msg("Ignoring $path"); | ||||
| 3366 | 0 | 0 | next; | ||||
| 3367 | } | ||||||
| 3368 | 0 | 0 | open (my $fh, '<', $path) or fatal_err("Can't open $path"); | ||||
| 3369 | 0 | 0 | my $data; | ||||
| 3370 | { | ||||||
| 3371 | 0 0 | 0 0 | local $/ = undef; | ||||
| 3372 | 0 | 0 | $data = from_json( <$fh> ); | ||||
| 3373 | } | ||||||
| 3374 | 0 | 0 | close($fh); | ||||
| 3375 | 0 | 0 | my $owner = $owners{$owner_name}; | ||||
| 3376 | 0 | 0 | if (! $owner) { | ||||
| 3377 | 0 | 0 | err_msg("Referencing unknown owner:$owner_name in $path"); | ||||
| 3378 | 0 | 0 | next; | ||||
| 3379 | } | ||||||
| 3380 | 0 | 0 | $owner->{watchers} and | ||||
| 3381 | err_msg("Redefining watcher of owner:$owner_name from $path"); | ||||||
| 3382 | 0 | 0 | $owner->{watchers} = $data; | ||||
| 3383 | } | ||||||
| 3384 | } | ||||||
| 3385 | 0 | 0 | return; | ||||
| 3386 | } | ||||||
| 3387 | |||||||
| 3388 | sub read_json { | ||||||
| 3389 | 0 | 0 | 0 | my ($path) = @_; | |||
| 3390 | 0 | 0 | opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!"); | ||||
| 3391 | 0 0 | 0 0 | my @files = map({ Encode::decode($filename_encode, $_) } readdir $dh); | ||||
| 3392 | 0 | 0 | closedir $dh; | ||||
| 3393 | 0 | 0 | for my $file (@files) { | ||||
| 3394 | 0 | 0 | next if $file =~ /^\./; | ||||
| 3395 | 0 | 0 | next if $file =~ m/$config{ignore_files}/o; | ||||
| 3396 | 0 | 0 | my $path = "$path/$file"; | ||||
| 3397 | 0 | 0 | if ($file ne 'owner') { | ||||
| 3398 | 0 | 0 | err_msg("Ignoring $path"); | ||||
| 3399 | 0 | 0 | next; | ||||
| 3400 | } | ||||||
| 3401 | 0 | 0 | read_json_watchers($path); | ||||
| 3402 | } | ||||||
| 3403 | 0 | 0 | return; | ||||
| 3404 | } | ||||||
| 3405 | |||||||
| 3406 | sub read_file_or_dir { | ||||||
| 3407 | 337 | 0 | 369 | my ($path, $read_syntax) = @_; | |||
| 3408 | 337 | 1101 | $read_syntax ||= \&read_netspoc; | ||||
| 3409 | |||||||
| 3410 | # Handle toplevel file. | ||||||
| 3411 | 337 | 1866 | if (!(defined $path && -d $path)) { | ||||
| 3412 | 32 | 61 | read_file($path, $read_syntax); | ||||
| 3413 | 32 | 54 | return; | ||||
| 3414 | } | ||||||
| 3415 | |||||||
| 3416 | # Recursively read files and directories. | ||||||
| 3417 | 305 | 260 | my $read_nested_files; | ||||
| 3418 | my $read_nested_files0 = sub { | ||||||
| 3419 | 313 | 322 | my ($path, $read_syntax) = @_; | ||||
| 3420 | 313 | 1148 | if (-d $path) { | ||||
| 3421 | 3 | 22 | opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!"); | ||||
| 3422 | 3 | 19 | while (my $file = Encode::decode($filename_encode, readdir $dh)) { | ||||
| 3423 | 10 | 34 | next if $file =~ /^\./; | ||||
| 3424 | 4 | 35 | next if $file =~ m/$config{ignore_files}/o; | ||||
| 3425 | 4 | 10 | my $path = "$path/$file"; | ||||
| 3426 | 4 | 10 | $read_nested_files->($path, $read_syntax); | ||||
| 3427 | } | ||||||
| 3428 | 3 | 17 | closedir $dh; | ||||
| 3429 | } | ||||||
| 3430 | else { | ||||||
| 3431 | 310 | 483 | read_file $path, $read_syntax; | ||||
| 3432 | } | ||||||
| 3433 | 305 | 1137 | }; | ||||
| 3434 | |||||||
| 3435 | # Special handling for "*.private". | ||||||
| 3436 | $read_nested_files = sub { | ||||||
| 3437 | 313 | 364 | my ($path, $read_syntax) = @_; | ||||
| 3438 | |||||||
| 3439 | # Handle private directories and files. | ||||||
| 3440 | 313 | 723 | if (my ($name) = ($path =~ m'([^/]*)\.private$')) { | ||||
| 3441 | 5 | 9 | if ($private) { | ||||
| 3442 | 1 | 4 | err_msg("Nested private context is not supported:\n $path"); | ||||
| 3443 | } | ||||||
| 3444 | 5 | 7 | local $private = $name; | ||||
| 3445 | 5 | 9 | $read_nested_files0->($path, $read_syntax); | ||||
| 3446 | } | ||||||
| 3447 | else { | ||||||
| 3448 | 308 | 410 | $read_nested_files0->($path, $read_syntax); | ||||
| 3449 | } | ||||||
| 3450 | 305 | 712 | }; | ||||
| 3451 | |||||||
| 3452 | # Handle toplevel directory. | ||||||
| 3453 | # Special handling for "config", "raw" and "JSON". | ||||||
| 3454 | 305 | 1902 | opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!"); | ||||
| 3455 | 305 919 | 1442 1719 | my @files = map({ Encode::decode($filename_encode, $_) } readdir $dh); | ||||
| 3456 | 305 | 854 | closedir $dh; | ||||
| 3457 | |||||||
| 3458 | 305 919 | 373 1538 | if (grep { $_ eq 'JSON' } @files) { | ||||
| 3459 | 0 | 0 | $can_json or | ||||
| 3460 | fatal_err("JSON module must be installed to read $path/JSON"); | ||||||
| 3461 | 0 | 0 | $from_json = { JSON => 1 }; | ||||
| 3462 | 0 | 0 | if (-e "$path/JSON/owner") { | ||||
| 3463 | 0 | 0 | $from_json->{watchers} = 1; | ||||
| 3464 | } | ||||||
| 3465 | } | ||||||
| 3466 | |||||||
| 3467 | 305 | 391 | for my $file (@files) { | ||||
| 3468 | |||||||
| 3469 | 919 | 2014 | next if $file =~ /^\./; | ||||
| 3470 | 309 | 1954 | next if $file =~ m/$config{ignore_files}/o; | ||||
| 3471 | |||||||
| 3472 | # Ignore special files/directories. | ||||||
| 3473 | 309 | 669 | next if $file =~ /^(config|raw|JSON)$/; | ||||
| 3474 | |||||||
| 3475 | 309 | 651 | my $path = "$path/$file"; | ||||
| 3476 | 309 | 465 | $read_nested_files->($path, $read_syntax); | ||||
| 3477 | } | ||||||
| 3478 | 305 | 717 | if (keys %$from_json) { | ||||
| 3479 | 0 | 0 | read_json("$path/JSON"); | ||||
| 3480 | } | ||||||
| 3481 | 305 | 729 | return; | ||||
| 3482 | } | ||||||
| 3483 | |||||||
| 3484 | sub show_read_statistics { | ||||||
| 3485 | 305 | 0 | 366 | my $n = keys %networks; | |||
| 3486 | 305 | 279 | my $h = keys %hosts; | ||||
| 3487 | 305 | 293 | my $r = keys %routers; | ||||
| 3488 | 305 | 269 | my $g = keys %groups; | ||||
| 3489 | 305 | 277 | my $s = keys %protocols; | ||||
| 3490 | 305 | 253 | my $sg = keys %protocolgroups; | ||||
| 3491 | 305 | 261 | my $p = keys %services; | ||||
| 3492 | 305 | 946 | info("Read $r routers, $n networks, $h hosts"); | ||||
| 3493 | 305 | 874 | info("Read $p services, $g groups, $s protocols, $sg protocol groups"); | ||||
| 3494 | 305 | 309 | return; | ||||
| 3495 | } | ||||||
| 3496 | |||||||
| 3497 | ## no critic (RequireArgUnpacking RequireFinalReturn) | ||||||
| 3498 | |||||||
| 3499 | # Type checking functions | ||||||
| 3500 | 1734 | 0 | 4900 | sub is_network { ref($_[0]) eq 'Network'; } | |||
| 3501 | 3835 | 0 | 9549 | sub is_router { ref($_[0]) eq 'Router'; } | |||
| 3502 | 3010 | 0 | 9065 | sub is_interface { ref($_[0]) eq 'Interface'; } | |||
| 3503 | 1002 | 0 | 1824 | sub is_host { ref($_[0]) eq 'Host'; } | |||
| 3504 | 64 | 0 | 214 | sub is_subnet { ref($_[0]) eq 'Subnet'; } | |||
| 3505 | 118 | 0 | 232 | sub is_area { ref($_[0]) eq 'Area'; } | |||
| 3506 | 464 | 0 | 693 | sub is_zone { ref($_[0]) eq 'Zone'; } | |||
| 3507 | 1246 | 0 | 3685 | sub is_group { ref($_[0]) eq 'Group'; } | |||
| 3508 | 0 | 0 | 0 | sub is_protocolgroup { ref($_[0]) eq 'Protocolgroup'; } | |||
| 3509 | 2219 | 0 | 5533 | sub is_objectgroup { ref($_[0]) eq 'Objectgroup'; } | |||
| 3510 | 128 | 0 | 294 | sub is_chain { ref($_[0]) eq 'Chain'; } | |||
| 3511 | 1809 | 0 | 4011 | sub is_autointerface { ref($_[0]) eq 'Autointerface'; } | |||
| 3512 | |||||||
| 3513 | ## use critic | ||||||
| 3514 | |||||||
| 3515 | sub print_rule { | ||||||
| 3516 | 61 | 0 | 57 | my ($rule) = @_; | |||
| 3517 | 61 | 47 | my $extra = ''; | ||||
| 3518 | 61 | 188 | my $service = $rule->{rule} && $rule->{rule}->{service}; | ||||
| 3519 | 61 | 92 | $extra .= " $rule->{for_router}" if $rule->{for_router}; | ||||
| 3520 | 61 | 92 | $extra .= " stateless" if $rule->{stateless}; | ||||
| 3521 | 61 | 80 | $extra .= " stateless_icmp" if $rule->{stateless_icmp}; | ||||
| 3522 | 61 | 128 | $extra .= " of $service->{name}" if $service; | ||||
| 3523 | 61 | 142 | my $prt = $rule->{orig_prt} || $rule->{prt}; | ||||
| 3524 | 61 | 88 | my $action = $rule->{deny} ? 'deny' : 'permit'; | ||||
| 3525 | 61 | 100 | if (my $chain = $rule->{chain}) { | ||||
| 3526 | 0 | 0 | $action = $chain->{name}; | ||||
| 3527 | } | ||||||
| 3528 | return | ||||||
| 3529 | 61 | 361 | $action | ||||
| 3530 | . " src=$rule->{src}->{name}; dst=$rule->{dst}->{name}; " | ||||||
| 3531 | . "prt=$prt->{name};$extra"; | ||||||
| 3532 | } | ||||||
| 3533 | |||||||
| 3534 | ############################################################################## | ||||||
| 3535 | # Order protocols | ||||||
| 3536 | ############################################################################## | ||||||
| 3537 | |||||||
| 3538 | # Hash for converting a reference of a protocol back to this protocol. | ||||||
| 3539 | our %ref2prt; | ||||||
| 3540 | |||||||
| 3541 | # Look up a protocol object by its defining attributes. | ||||||
| 3542 | my %prt_hash; | ||||||
| 3543 | |||||||
| 3544 | sub prepare_prt_ordering { | ||||||
| 3545 | 4954 | 0 | 3830 | my ($prt) = @_; | |||
| 3546 | 4954 | 4556 | my $proto = $prt->{proto}; | ||||
| 3547 | 4954 | 3685 | my $main_prt; | ||||
| 3548 | 4954 | 14543 | if ($proto eq 'tcp' or $proto eq 'udp') { | ||||
| 3549 | |||||||
| 3550 | # Convert src and dst port ranges from arrays to real protocol objects. | ||||||
| 3551 | # This is used in function expand_rules via expand_protocols: | ||||||
| 3552 | # An unexpanded rule has references to TCP and UDP protocols | ||||||
| 3553 | # with combined src and dst port ranges. An expanded rule has | ||||||
| 3554 | # distinct references to src and dst protocols with a single | ||||||
| 3555 | # port range. | ||||||
| 3556 | 2577 | 2458 | for my $where ('src_range', 'dst_range') { | ||||
| 3557 | |||||||
| 3558 | # An array with low and high port. | ||||||
| 3559 | 5154 | 8201 | my $range = $prt->{$where} or next; | ||||
| 3560 | 3246 | 5962 | my $key = join ':', @$range; | ||||
| 3561 | 3246 | 3539 | my $range_prt = $prt_hash{$proto}->{$key}; | ||||
| 3562 | 3246 | 4147 | if (not $range_prt) { | ||||
| 3563 | 2225 | 4570 | $range_prt = { | ||||
| 3564 | name => $prt->{name}, | ||||||
| 3565 | proto => $proto, | ||||||
| 3566 | range => $range, | ||||||
| 3567 | }; | ||||||
| 3568 | 2225 | 2977 | $prt_hash{$proto}->{$key} = $range_prt; | ||||
| 3569 | |||||||
| 3570 | # Set up ref2prt. | ||||||
| 3571 | 2225 | 4418 | $ref2prt{$range_prt} = $range_prt; | ||||
| 3572 | } | ||||||
| 3573 | 3246 | 5535 | $prt->{$where} = $range_prt; | ||||
| 3574 | } | ||||||
| 3575 | } | ||||||
| 3576 | elsif ($proto eq 'icmp') { | ||||||
| 3577 | 365 | 533 | my $type = $prt->{type}; | ||||
| 3578 | 365 | 349 | my $code = $prt->{code}; | ||||
| 3579 | 365 | 537 | my $key = defined $type ? (defined $code ? "$type:$code" : $type) : ''; | ||||
| 3580 | 365 | 1077 | $main_prt = $prt_hash{$proto}->{$key} | ||||
| 3581 | or $prt_hash{$proto}->{$key} = $prt; | ||||||
| 3582 | } | ||||||
| 3583 | elsif ($proto eq 'ip') { | ||||||
| 3584 | 356 | 775 | $main_prt = $prt_hash{$proto} | ||||
| 3585 | or $prt_hash{$proto} = $prt; | ||||||
| 3586 | } | ||||||
| 3587 | else { | ||||||
| 3588 | |||||||
| 3589 | # Other protocol. | ||||||
| 3590 | 1656 | 1436 | my $key = $proto; | ||||
| 3591 | 1656 | 3365 | $main_prt = $prt_hash{proto}->{$key} | ||||
| 3592 | or $prt_hash{proto}->{$key} = $prt; | ||||||
| 3593 | } | ||||||
| 3594 | 4954 | 6883 | if ($main_prt) { | ||||
| 3595 | |||||||
| 3596 | # Found duplicate protocol definition. Link $prt with $main_prt. | ||||||
| 3597 | # We link all duplicate protocols to the first protocol found. | ||||||
| 3598 | # This assures that we always reach the main protocol from any duplicate | ||||||
| 3599 | # protocol in one step via ->{main}. This is used later to substitute | ||||||
| 3600 | # occurrences of $prt with $main_prt. | ||||||
| 3601 | 33 | 44 | $prt->{main} = $main_prt; | ||||
| 3602 | } | ||||||
| 3603 | 4954 | 5275 | return; | ||||
| 3604 | } | ||||||
| 3605 | |||||||
| 3606 | sub order_icmp { | ||||||
| 3607 | 331 | 0 | 325 | my ($hash, $up) = @_; | |||
| 3608 | |||||||
| 3609 | # Handle 'icmp any'. | ||||||
| 3610 | 331 | 590 | if (my $prt = $hash->{''}) { | ||||
| 3611 | 331 | 325 | $prt->{up} = $up; | ||||
| 3612 | 331 | 481 | $up = $prt; | ||||
| 3613 | } | ||||||
| 3614 | 331 | 583 | for my $prt (values %$hash) { | ||||
| 3615 | |||||||
| 3616 | # 'icmp any' has been handled above. | ||||||
| 3617 | 358 | 620 | if (!defined $prt->{type}) { | ||||
| 3618 | } | ||||||
| 3619 | elsif (defined $prt->{code}) { | ||||||
| 3620 | 0 | 0 | $prt->{up} = ($hash->{ $prt->{type} } or $up); | ||||
| 3621 | } | ||||||
| 3622 | else { | ||||||
| 3623 | 27 | 33 | $prt->{up} = $up; | ||||
| 3624 | } | ||||||
| 3625 | |||||||
| 3626 | # Set up ref2prt. | ||||||
| 3627 | 358 | 1928 | $ref2prt{$prt} = $prt; | ||||
| 3628 | } | ||||||
| 3629 | 331 | 403 | return; | ||||
| 3630 | } | ||||||
| 3631 | |||||||
| 3632 | sub order_proto { | ||||||
| 3633 | 331 | 0 | 322 | my ($hash, $up) = @_; | |||
| 3634 | 331 | 553 | for my $prt (values %$hash) { | ||||
| 3635 | 1655 | 1478 | $prt->{up} = $up; | ||||
| 3636 | |||||||
| 3637 | # Set up ref2prt. | ||||||
| 3638 | 1655 | 2440 | $ref2prt{$prt} = $prt; | ||||
| 3639 | } | ||||||
| 3640 | 331 | 369 | return; | ||||
| 3641 | } | ||||||
| 3642 | |||||||
| 3643 | # Set {up} relation from port range to the smallest port range which | ||||||
| 3644 | # includes it. | ||||||
| 3645 | # If no including range is found, link it with next larger protocol. | ||||||
| 3646 | # Set attribute {has_neighbor} to range adjacent to upper port. | ||||||
| 3647 | # Find overlapping ranges and split one of them to eliminate the overlap. | ||||||
| 3648 | # Set attribute {split} at original range, referencing pair of splitted ranges. | ||||||
| 3649 | sub order_ranges { | ||||||
| 3650 | 662 | 0 | 641 | my ($range_href, $up) = @_; | |||
| 3651 | 2801 | 5335 | my @sorted = | ||||
| 3652 | |||||||
| 3653 | # Sort by low port. If low ports are equal, sort reverse by high port. | ||||||
| 3654 | # I.e. larger ranges coming first, if there are multiple ranges | ||||||
| 3655 | # with identical low port. | ||||||
| 3656 | sort { | ||||||
| 3657 | 662 | 1604 | $a->{range}->[0] <=> $b->{range}->[0] | ||||
| 3658 | || $b->{range}->[1] <=> $a->{range}->[1] | ||||||
| 3659 | } values %$range_href; | ||||||
| 3660 | |||||||
| 3661 | # Check current range [a1, a2] for sub-ranges, starting at position $i. | ||||||
| 3662 | # Return position of range which isn't sub-range or undef | ||||||
| 3663 | # if end of array is reached. | ||||||
| 3664 | 662 | 497 | my $check_subrange; | ||||
| 3665 | |||||||
| 3666 | $check_subrange = sub { | ||||||
| 3667 | 2225 | 2662 | my ($a, $a1, $a2, $i) = @_; | ||||
| 3668 | 2225 | 1602 | while (1) { | ||||
| 3669 | 3279 | 4754 | return if $i == @sorted; | ||||
| 3670 | 2617 | 2065 | my $b = $sorted[$i]; | ||||
| 3671 | 2617 2617 | 1834 3283 | my ($b1, $b2) = @{ $b->{range} }; | ||||
| 3672 | |||||||
| 3673 | # Neighbors | ||||||
| 3674 | # aaaabbbb | ||||||
| 3675 | 2617 | 3610 | if ($a2 + 1 == $b1) { | ||||
| 3676 | |||||||
| 3677 | # Mark protocol as candidate for joining of port ranges during | ||||||
| 3678 | # optimization. | ||||||
| 3679 | 36 | 47 | $a->{has_neighbor} = $b->{has_neighbor} = 1; | ||||
| 3680 | } | ||||||
| 3681 | |||||||
| 3682 | # Not related. | ||||||
| 3683 | # aaaa bbbbb | ||||||
| 3684 | 2617 | 3834 | return $i if $a2 < $b1; | ||||
| 3685 | |||||||
| 3686 | # $a includes $b. | ||||||
| 3687 | # aaaaaaa | ||||||
| 3688 | # bbbbb | ||||||
| 3689 | 1564 | 2109 | if ($a2 >= $b2) { | ||||
| 3690 | 1563 | 1406 | $b->{up} = $a; | ||||
| 3691 | |||||||
| 3692 | # debug("$b->{name} [$b1-$b2] < $a->{name} [$a1-$a2]"); | ||||||
| 3693 | 1563 | 2892 | $i = $check_subrange->($b, $b1, $b2, $i + 1); | ||||
| 3694 | |||||||
| 3695 | # Stop at end of array. | ||||||
| 3696 | 1563 | 2584 | $i or return; | ||||
| 3697 | 1053 | 896 | next; | ||||
| 3698 | } | ||||||
| 3699 | |||||||
| 3700 | # $a and $b are overlapping. | ||||||
| 3701 | # aaaaa | ||||||
| 3702 | # bbbbbb | ||||||
| 3703 | # Split $b in two parts $x and $y with $x included by $b: | ||||||
| 3704 | # aaaaa | ||||||
| 3705 | # xxxyyy | ||||||
| 3706 | 1 | 1 | my $x1 = $b1; | ||||
| 3707 | 1 | 2 | my $x2 = $a2; | ||||
| 3708 | 1 | 1 | my $y1 = $a2 + 1; | ||||
| 3709 | 1 | 1 | my $y2 = $b2; | ||||
| 3710 | |||||||
| 3711 | # debug("$b->{name} [$b1-$b2] split into [$x1-$x2] and [$y1-$y2]"); | ||||||
| 3712 | my $find_or_insert_range = sub { | ||||||
| 3713 | 2 | 3 | my ($a1, $a2, $i, $orig, $prefix) = @_; | ||||
| 3714 | 2 | 2 | while (1) { | ||||
| 3715 | 3 | 4 | if ($i == @sorted) { | ||||
| 3716 | 1 | 1 | last; | ||||
| 3717 | } | ||||||
| 3718 | 2 | 3 | my $b = $sorted[$i]; | ||||
| 3719 | 2 2 | 2 3 | my ($b1, $b2) = @{ $b->{range} }; | ||||
| 3720 | |||||||
| 3721 | # New range starts at higher position and therefore must | ||||||
| 3722 | # be inserted behind current range. | ||||||
| 3723 | 2 | 4 | if ($a1 > $b1) { | ||||
| 3724 | 1 | 1 | $i++; | ||||
| 3725 | 1 | 1 | next; | ||||
| 3726 | } | ||||||
| 3727 | |||||||
| 3728 | # New and current range start a same position. | ||||||
| 3729 | 1 | 2 | if ($a1 == $b1) { | ||||
| 3730 | |||||||
| 3731 | # New range is smaller and therefore must be inserted | ||||||
| 3732 | # behind current range. | ||||||
| 3733 | 1 | 2 | if ($a2 < $b2) { | ||||
| 3734 | 0 | 0 | $i++; | ||||
| 3735 | 0 | 0 | next; | ||||
| 3736 | } | ||||||
| 3737 | |||||||
| 3738 | # Found identical range, return this one. | ||||||
| 3739 | 1 | 2 | if ($a2 == $b2) { | ||||
| 3740 | |||||||
| 3741 | # debug("Splitted range is already defined: $b->{name}"); | ||||||
| 3742 | 1 | 2 | return $b; | ||||
| 3743 | } | ||||||
| 3744 | |||||||
| 3745 | # New range is larger than current range and therefore | ||||||
| 3746 | # must be inserted in front of current one. | ||||||
| 3747 | 0 | 0 | last; | ||||
| 3748 | } | ||||||
| 3749 | |||||||
| 3750 | # New range starts at lower position than current one. | ||||||
| 3751 | # It must be inserted in front of current range. | ||||||
| 3752 | 0 | 0 | last; | ||||
| 3753 | } | ||||||
| 3754 | 1 | 5 | my $new_range = { | ||||
| 3755 | name => "$prefix$orig->{name}", | ||||||
| 3756 | proto => $orig->{proto}, | ||||||
| 3757 | range => [ $a1, $a2 ], | ||||||
| 3758 | |||||||
| 3759 | # Mark for range optimization. | ||||||
| 3760 | has_neighbor => 1 | ||||||
| 3761 | }; | ||||||
| 3762 | |||||||
| 3763 | # Insert new range at position $i. | ||||||
| 3764 | 1 | 4 | splice @sorted, $i, 0, $new_range; | ||||
| 3765 | |||||||
| 3766 | # Set up ref2prt. | ||||||
| 3767 | 1 | 1 | $ref2prt{$new_range} = $new_range; | ||||
| 3768 | |||||||
| 3769 | 1 | 2 | return $new_range; | ||||
| 3770 | 1 | 4 | }; | ||||
| 3771 | 1 | 2 | my $left = $find_or_insert_range->($x1, $x2, $i + 1, $b, 'lpart_'); | ||||
| 3772 | 1 | 2 | my $rigth = $find_or_insert_range->($y1, $y2, $i + 1, $b, 'rpart_'); | ||||
| 3773 | 1 | 2 | $b->{split} = [ $left, $rigth ]; | ||||
| 3774 | |||||||
| 3775 | # Continue processing with next element. | ||||||
| 3776 | 1 | 5 | $i++; | ||||
| 3777 | } | ||||||
| 3778 | 662 | 2339 | }; | ||||
| 3779 | |||||||
| 3780 | # Array wont be empty because $prt_tcp and $prt_udp are defined internally. | ||||||
| 3781 | 662 | 1127 | @sorted or internal_err("Unexpected empty array"); | ||||
| 3782 | |||||||
| 3783 | 662 | 576 | my $a = $sorted[0]; | ||||
| 3784 | 662 | 683 | $a->{up} = $up; | ||||
| 3785 | 662 662 | 528 1027 | my ($a1, $a2) = @{ $a->{range} }; | ||||
| 3786 | |||||||
| 3787 | # Ranges "TCP any" and "UDP any" 1..65535 are defined internally, | ||||||
| 3788 | # they include all other ranges. | ||||||
| 3789 | 662 | 2119 | $a1 == 1 and $a2 == 65535 | ||||
| 3790 | or internal_err("Expected $a->{name} to have range 1..65535"); | ||||||
| 3791 | |||||||
| 3792 | # There can't be any port which isn't included by ranges "TCP any" | ||||||
| 3793 | # or "UDP any". | ||||||
| 3794 | 662 | 916 | $check_subrange->($a, $a1, $a2, 1) and internal_err(); | ||||
| 3795 | 662 | 744 | return; | ||||
| 3796 | } | ||||||
| 3797 | |||||||
| 3798 | sub expand_splitted_protocol { | ||||||
| 3799 | 290 | 0 | 281 | my ($prt) = @_; | |||
| 3800 | |||||||
| 3801 | # Handle unset src_range. | ||||||
| 3802 | 290 | 585 | if (not $prt) { | ||||
| 3803 | 19 | 30 | return $prt; | ||||
| 3804 | } | ||||||
| 3805 | elsif (my $split = $prt->{split}) { | ||||||
| 3806 | 1 | 1 | my ($prt1, $prt2) = @$split; | ||||
| 3807 | 1 | 3 | return (expand_splitted_protocol($prt1), | ||||
| 3808 | expand_splitted_protocol($prt2)); | ||||||
| 3809 | } | ||||||
| 3810 | else { | ||||||
| 3811 | 270 | 391 | return $prt; | ||||
| 3812 | } | ||||||
| 3813 | } | ||||||
| 3814 | |||||||
| 3815 | # Protocol 'ip' is needed later for implementing secondary rules and | ||||||
| 3816 | # automatically generated deny rules. | ||||||
| 3817 | my $prt_ip; | ||||||
| 3818 | |||||||
| 3819 | # Protocol 'ICMP any', needed in optimization of chains for iptables. | ||||||
| 3820 | my $prt_icmp; | ||||||
| 3821 | |||||||
| 3822 | # Protocol 'TCP any'. | ||||||
| 3823 | my $prt_tcp; | ||||||
| 3824 | |||||||
| 3825 | # Protocol 'UDP any'. | ||||||
| 3826 | my $prt_udp; | ||||||
| 3827 | |||||||
| 3828 | # DHCP server. | ||||||
| 3829 | my $prt_bootps; | ||||||
| 3830 | |||||||
| 3831 | # IPSec: Internet key exchange. | ||||||
| 3832 | # Source and destination port (range) is set to 500. | ||||||
| 3833 | my $prt_ike; | ||||||
| 3834 | |||||||
| 3835 | # IPSec: NAT traversal. | ||||||
| 3836 | my $prt_natt; | ||||||
| 3837 | |||||||
| 3838 | # IPSec: encryption security payload. | ||||||
| 3839 | my $prt_esp; | ||||||
| 3840 | |||||||
| 3841 | # IPSec: authentication header. | ||||||
| 3842 | my $prt_ah; | ||||||
| 3843 | |||||||
| 3844 | # Port range 'TCP any'; assigned in sub order_protocols below. | ||||||
| 3845 | my $range_tcp_any; | ||||||
| 3846 | |||||||
| 3847 | # Port range 'tcp established' is needed later for reverse rules | ||||||
| 3848 | # and assigned below. | ||||||
| 3849 | my $range_tcp_established; | ||||||
| 3850 | |||||||
| 3851 | # Order protocols. We need this to simplify optimization. | ||||||
| 3852 | # Additionally add internal predefined protocols. | ||||||
| 3853 | sub order_protocols { | ||||||
| 3854 | 331 | 0 | 453 | progress('Arranging protocols'); | |||
| 3855 | |||||||
| 3856 | # Internal protocols need to be processed before user defined protocols, | ||||||
| 3857 | # because we want to avoid handling of {main} for internal protocols. | ||||||
| 3858 | # $prt_tcp and $prt_udp need to be processed before all other TCP and UDP | ||||||
| 3859 | # protocols, because otherwise the range 1..65535 would get a misleading | ||||||
| 3860 | # name. | ||||||
| 3861 | 331 2317 | 718 3917 | for my $prt ( | ||||
| 3862 | $prt_ip, $prt_icmp, $prt_tcp, | ||||||
| 3863 | $prt_udp, $prt_bootps, $prt_ike, $prt_natt, | ||||||
| 3864 | $prt_esp, $prt_ah, | ||||||
| 3865 | map({ $_->{prt} ? ($_->{prt}) : () } | ||||||
| 3866 | values %routing_info, values %xxrp_info), | ||||||
| 3867 | values %protocols | ||||||
| 3868 | ) | ||||||
| 3869 | { | ||||||
| 3870 | 4954 | 5354 | prepare_prt_ordering $prt; | ||||
| 3871 | } | ||||||
| 3872 | |||||||
| 3873 | 331 | 456 | $range_tcp_any = $prt_tcp->{dst_range}; | ||||
| 3874 | 331 | 1262 | $range_tcp_established = { | ||||
| 3875 | %$range_tcp_any, | ||||||
| 3876 | name => 'reversed:TCP_ANY', | ||||||
| 3877 | established => 1 | ||||||
| 3878 | }; | ||||||
| 3879 | 331 | 666 | $range_tcp_established->{up} = $range_tcp_any; | ||||
| 3880 | |||||||
| 3881 | 331 | 282 | my $up = $prt_ip; | ||||
| 3882 | 331 | 568 | order_ranges($prt_hash{tcp}, $up); | ||||
| 3883 | 331 | 464 | order_ranges($prt_hash{udp}, $up); | ||||
| 3884 | 331 | 508 | order_icmp($prt_hash{icmp}, $up); | ||||
| 3885 | 331 | 461 | order_proto($prt_hash{proto}, $up); | ||||
| 3886 | |||||||
| 3887 | # Set up ref2prt. | ||||||
| 3888 | 331 | 458 | $ref2prt{$prt_ip} = $prt_ip; | ||||
| 3889 | 331 | 330 | return; | ||||
| 3890 | } | ||||||
| 3891 | |||||||
| 3892 | #################################################################### | ||||||
| 3893 | # Link topology elements each with another | ||||||
| 3894 | #################################################################### | ||||||
| 3895 | |||||||
| 3896 | sub expand_group; | ||||||
| 3897 | |||||||
| 3898 | sub link_to_owner { | ||||||
| 3899 | 2401 | 0 | 1856 | my ($obj, $key) = @_; | |||
| 3900 | 2401 | 5014 | $key ||= 'owner'; | ||||
| 3901 | 2401 | 3476 | if (my $value = $obj->{$key}) { | ||||
| 3902 | 66 | 125 | if (my $owner = $owners{$value}) { | ||||
| 3903 | 64 | 127 | return $obj->{$key} = $owner; | ||||
| 3904 | } | ||||||
| 3905 | 2 | 8 | err_msg("Can't resolve reference to '$value'", | ||||
| 3906 | " in attribute '$key' of $obj->{name}"); | ||||||
| 3907 | 2 | 4 | delete $obj->{$key}; | ||||
| 3908 | } | ||||||
| 3909 | 2337 | 3462 | return; | ||||
| 3910 | } | ||||||
| 3911 | |||||||
| 3912 | sub link_to_real_owner { | ||||||
| 3913 | 2335 | 0 | 1897 | my ($obj, $key) = @_; | |||
| 3914 | 2335 | 2514 | if (my $owner = link_to_owner($obj, $key)) { | ||||
| 3915 | 39 | 70 | if ($owner->{extend_only}) { | ||||
| 3916 | |||||||
| 3917 | # Prevent further errors. | ||||||
| 3918 | 3 | 4 | delete $owner->{extend_only}; | ||||
| 3919 | 3 | 11 | err_msg("$owner->{name} with attribute 'extend_only'", | ||||
| 3920 | " must only be used at area,\n not at $obj->{name}"); | ||||||
| 3921 | } | ||||||
| 3922 | } | ||||||
| 3923 | 2335 | 2253 | return; | ||||
| 3924 | } | ||||||
| 3925 | |||||||
| 3926 | # Element of attribute 'watchers' of owner A is allowed to reference | ||||||
| 3927 | # some other owner B. In this case all admins and watchers of B are | ||||||
| 3928 | # added to watchers of A. | ||||||
| 3929 | sub expand_watchers { | ||||||
| 3930 | 69 | 0 | 68 | my ($owner) = @_; | |||
| 3931 | 69 | 75 | my $names = $owner->{watchers}; | ||||
| 3932 | |||||||
| 3933 | # No wathers given. | ||||||
| 3934 | 69 | 98 | if (!$names) { | ||||
| 3935 | 51 | 67 | return $owner->{admins}; | ||||
| 3936 | } | ||||||
| 3937 | |||||||
| 3938 | # Owners, referenced in $names have already been resolved. | ||||||
| 3939 | 18 | 31 | if ($owner->{watching_owners}) { | ||||
| 3940 | 3 3 | 3 6 | return [ @{ $owner->{admins} }, @$names ]; | ||||
| 3941 | } | ||||||
| 3942 | 15 | 29 | if ($names eq 'recursive') { | ||||
| 3943 | 1 | 3 | err_msg("Found recursive definition of watchers in $owner->{name}"); | ||||
| 3944 | 1 | 4 | return $owner->{watchers} = []; | ||||
| 3945 | } | ||||||
| 3946 | 14 | 15 | $owner->{watchers} = 'recursive'; | ||||
| 3947 | 14 | 17 | my $watching_owners = []; | ||||
| 3948 | 14 | 12 | my @expanded; | ||||
| 3949 | 14 | 18 | for my $name (@$names) { | ||||
| 3950 | 15 | 41 | if (my ($o_name) = ($name =~ /^owner:(.*)$/)) { | ||||
| 3951 | 6 | 8 | my $owner_b = $owners{$o_name}; | ||||
| 3952 | 6 | 10 | if (!$owner_b) { | ||||
| 3953 | 1 | 5 | err_msg("Unknown owner:$o_name referenced in watcher of", | ||||
| 3954 | " $owner->{name}"); | ||||||
| 3955 | 1 | 2 | next; | ||||
| 3956 | } | ||||||
| 3957 | 5 | 5 | push @$watching_owners, $owner_b; | ||||
| 3958 | 5 5 | 5 15 | push @expanded, @{ expand_watchers($owner_b) }; | ||||
| 3959 | } | ||||||
| 3960 | else { | ||||||
| 3961 | 9 | 21 | push @expanded, $name; | ||||
| 3962 | } | ||||||
| 3963 | } | ||||||
| 3964 | 14 | 21 | $owner->{watchers} = \@expanded; | ||||
| 3965 | |||||||
| 3966 | # Mark: no need to expand again and for cut-netspoc. | ||||||
| 3967 | 14 | 14 | $owner->{watching_owners} = $watching_owners; | ||||
| 3968 | |||||||
| 3969 | 14 14 | 13 39 | return [ @{ $owner->{admins} }, @expanded ]; | ||||
| 3970 | } | ||||||
| 3971 | |||||||
| 3972 | sub link_owners { | ||||||
| 3973 | |||||||
| 3974 | 337 | 0 | 274 | my %alias2owner; | |||
| 3975 | |||||||
| 3976 | # Use sort to get deterministic error messages. | ||||||
| 3977 | 337 | 860 | for my $name (sort keys %owners) { | ||||
| 3978 | 64 | 81 | my $owner = $owners{$name}; | ||||
| 3979 | |||||||
| 3980 | # Check for unique alias names. | ||||||
| 3981 | 64 | 202 | my $alias = $owner->{alias} || $name; | ||||
| 3982 | 64 | 107 | if (my $other = $alias2owner{$alias}) { | ||||
| 3983 | 2 | 2 | my $descr1 = $owner->{name}; | ||||
| 3984 | 2 | 7 | $owner->{alias} and $descr1 .= " with alias '$owner->{alias}'"; | ||||
| 3985 | 2 | 2 | my $descr2 = $other->{name}; | ||||
| 3986 | 2 | 5 | $other->{alias} and $descr2 .= " with alias '$other->{alias}'"; | ||||
| 3987 | 2 | 6 | err_msg("Name conflict between owners\n - $descr1\n - $descr2"); | ||||
| 3988 | } | ||||||
| 3989 | else { | ||||||
| 3990 | 62 | 84 | $alias2owner{$alias} = $owner; | ||||
| 3991 | } | ||||||
| 3992 | |||||||
| 3993 | # Check and expand referenced owners in watchers. | ||||||
| 3994 | 64 | 86 | expand_watchers($owner); | ||||
| 3995 | |||||||
| 3996 | # Check email addresses in admins and watchers. | ||||||
| 3997 | 64 | 76 | for my $attr (qw( admins watchers )) { | ||||
| 3998 | 128 128 | 100 235 | for my $email (@{ $owner->{$attr} }) { | ||||
| 3999 | |||||||
| 4000 | # Check email syntax. | ||||||
| 4001 | # Only 7 bit ASCII | ||||||
| 4002 | # Local part definition from wikipedia, | ||||||
| 4003 | # without space and other quoted characters | ||||||
| 4004 | 74 | 61 | do { | ||||
| 4005 | 70 70 70 | 452 89 374 | use bytes; | ||||
| 4006 | 74 | 4459 | $email =~ | ||||
| 4007 | m/^ [\w.!\#$%&''*+\/=?^_``{|}~-]+ \@ [\w.-]+ $/x || | ||||||
| 4008 | $email eq 'guest'; | ||||||
| 4009 | } | ||||||
| 4010 | or err_msg("Invalid email address (ASCII only)", | ||||||
| 4011 | " in $attr of $owner->{name}: $email"); | ||||||
| 4012 | |||||||
| 4013 | # Normalize email to lower case. | ||||||
| 4014 | 74 | 325 | $email = lc($email); | ||||
| 4015 | } | ||||||
| 4016 | } | ||||||
| 4017 | |||||||
| 4018 | # Check for duplicate email addresses | ||||||
| 4019 | # in admins, watchers and between admins and watchers. | ||||||
| 4020 | 64 64 64 | 63 74 106 | if (find_duplicates(@{ $owner->{admins} }, @{ $owner->{watchers} })) { | ||||
| 4021 | 1 | 2 | for my $attr (qw(admins watchers)) { | ||||
| 4022 | 2 2 | 2 4 | if (my @emails = find_duplicates(@{ $owner->{$attr} })) { | ||||
| 4023 | 1 1 | 2 2 | $owner->{$attr} = [ unique(@{ $owner->{$attr} }) ]; | ||||
| 4024 | 1 | 6 | err_msg("Duplicates in $attr of $owner->{name}: ", | ||||
| 4025 | join(', ', @emails)); | ||||||
| 4026 | } | ||||||
| 4027 | } | ||||||
| 4028 | 1 1 | 2 2 | if (my @duplicates = | ||||
| 4029 | 1 | 1 | find_duplicates(@{ $owner->{admins} }, @{ $owner->{watchers} })) | ||||
| 4030 | { | ||||||
| 4031 | 1 | 4 | err_msg("Duplicates in admins/watchers of $owner->{name}: ", | ||||
| 4032 | join(', ', @duplicates)); | ||||||
| 4033 | } | ||||||
| 4034 | } | ||||||
| 4035 | } | ||||||
| 4036 | 337 | 672 | for my $network (values %networks) { | ||||
| 4037 | 1115 | 1274 | link_to_real_owner($network); | ||||
| 4038 | 1115 1115 | 783 1851 | for my $host (@{ $network->{hosts} }) { | ||||
| 4039 | 181 | 219 | link_to_real_owner($host); | ||||
| 4040 | } | ||||||
| 4041 | } | ||||||
| 4042 | 337 | 562 | for my $aggregate (values %aggregates) { | ||||
| 4043 | 52 | 64 | link_to_real_owner($aggregate); | ||||
| 4044 | } | ||||||
| 4045 | 337 | 529 | for my $area (values %areas) { | ||||
| 4046 | 66 | 80 | link_to_owner($area); | ||||
| 4047 | 66 | 142 | if (my $router_attributes = $area->{router_attributes}) { | ||||
| 4048 | 7 | 62 | link_to_real_owner($router_attributes); | ||||
| 4049 | } | ||||||
| 4050 | } | ||||||
| 4051 | 337 | 500 | for my $router (values %routers, @router_fragments) { | ||||
| 4052 | 690 | 773 | link_to_real_owner($router); | ||||
| 4053 | 690 | 1414 | $router->{model}->{has_vip} or next; | ||||
| 4054 | 7 7 | 8 10 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 4055 | 16 | 20 | link_to_real_owner($interface); | ||||
| 4056 | } | ||||||
| 4057 | } | ||||||
| 4058 | 337 | 525 | for my $service (values %services) { | ||||
| 4059 | 274 | 330 | link_to_real_owner($service, 'sub_owner'); | ||||
| 4060 | } | ||||||
| 4061 | 337 | 399 | return; | ||||
| 4062 | } | ||||||
| 4063 | |||||||
| 4064 | sub link_policy_distribution_point { | ||||||
| 4065 | 697 | 0 | 589 | my ($obj) = @_; | |||
| 4066 | 697 | 1254 | my $pair = $obj->{policy_distribution_point} or return; | ||||
| 4067 | 10 | 15 | my ($type, $name) = @$pair; | ||||
| 4068 | 10 | 21 | if ($type ne 'host') { | ||||
| 4069 | 0 | 0 | err_msg("Must only use 'host' in 'policy_distribution_point'", | ||||
| 4070 | " of $obj->{name}"); | ||||||
| 4071 | |||||||
| 4072 | # Prevent further errors; | ||||||
| 4073 | 0 | 0 | delete $obj->{policy_distribution_point}; | ||||
| 4074 | 0 | 0 | return; | ||||
| 4075 | } | ||||||
| 4076 | 10 | 13 | my $host = $hosts{$name}; | ||||
| 4077 | 10 | 22 | if (!$host) { | ||||
| 4078 | 0 | 0 | warn_msg("Ignoring undefined host:$name", | ||||
| 4079 | " in 'policy_distribution_point' of $obj->{name}"); | ||||||
| 4080 | |||||||
| 4081 | # Prevent further errors; | ||||||
| 4082 | 0 | 0 | delete $obj->{policy_distribution_point}; | ||||
| 4083 | 0 | 0 | return; | ||||
| 4084 | } | ||||||
| 4085 | 10 | 12 | $obj->{policy_distribution_point} = $host; | ||||
| 4086 | 10 | 14 | return; | ||||
| 4087 | } | ||||||
| 4088 | |||||||
| 4089 | sub link_general_permit { | ||||||
| 4090 | 697 | 0 | 597 | my ($obj) = @_; | |||
| 4091 | 697 | 1388 | my $list = $obj->{general_permit} or return; | ||||
| 4092 | 21 | 24 | my $context = $obj->{name}; | ||||
| 4093 | |||||||
| 4094 | # Sort protocols and src_range/dst_range/orig_prt triples by name, | ||||||
| 4095 | # so we can compare value lists of attribute general_permit for | ||||||
| 4096 | # redundancy during inheritance. | ||||||
| 4097 | 9 | 33 | $list = $obj->{general_permit} = | ||||
| 4098 | 21 | 32 | [ sort { (ref $a eq 'ARRAY' ? $a->[2]->{name} : $a->{name}) | ||||
| 4099 | cmp | ||||||
| 4100 | (ref $b eq 'ARRAY' ? $b->[2]->{name} : $b->{name}) } | ||||||
| 4101 | 21 | 16 | @{ split_protocols(expand_protocols($list, $context)) } ]; | ||||
| 4102 | |||||||
| 4103 | # Don't allow port ranges. This wouldn't work, because | ||||||
| 4104 | # gen_reverse_rules doesn't handle generally permitted protocols. | ||||||
| 4105 | 21 | 39 | for my $prt (@$list) { | ||||
| 4106 | 28 | 23 | my $orig_prt; | ||||
| 4107 | my $src_range; | ||||||
| 4108 | 0 | 0 | my $range; | ||||
| 4109 | 28 | 44 | if (ref $prt eq 'ARRAY') { | ||||
| 4110 | 5 | 6 | ($src_range, my $dst_range, $orig_prt) = @$prt; | ||||
| 4111 | 5 | 6 | $range = $dst_range->{range}; | ||||
| 4112 | } | ||||||
| 4113 | else { | ||||||
| 4114 | 23 | 55 | $range = $prt->{range} or next; | ||||
| 4115 | 1 | 1 | $orig_prt = $prt; | ||||
| 4116 | } | ||||||
| 4117 | 6 | 6 | my @reason; | ||||
| 4118 | 6 | 10 | if (my $flags = $orig_prt->{flags}) { | ||||
| 4119 | 0 | 0 | push @reason, 'modifiers'; | ||||
| 4120 | } | ||||||
| 4121 | 6 | 26 | if ($src_range || $range && $range ne $aref_tcp_any) { | ||||
| 4122 | 2 | 2 | push @reason, 'ports'; | ||||
| 4123 | } | ||||||
| 4124 | 6 | 15 | if (@reason) { | ||||
| 4125 | 2 | 3 | my $reason = join ' or ', @reason; | ||||
| 4126 | 2 | 8 | err_msg("Must not use '$orig_prt->{name}' with $reason", | ||||
| 4127 | " in general_permit of $context"); | ||||||
| 4128 | } | ||||||
| 4129 | } | ||||||
| 4130 | 21 | 32 | return; | ||||
| 4131 | } | ||||||
| 4132 | |||||||
| 4133 | # Link areas with referenced interfaces or network. | ||||||
| 4134 | sub link_areas { | ||||||
| 4135 | 337 | 0 | 536 | for my $area (values %areas) { | |||
| 4136 | 66 | 115 | if ($area->{anchor}) { | ||||
| 4137 | 17 | 41 | my @elements = | ||||
| 4138 | 17 | 19 | @{ expand_group([ $area->{anchor} ], $area->{name}) }; | ||||
| 4139 | 17 | 41 | if (@elements == 1) { | ||||
| 4140 | 17 | 19 | my $obj = $elements[0]; | ||||
| 4141 | 17 | 28 | if (is_network $obj) { | ||||
| 4142 | 17 | 28 | $area->{anchor} = $obj; | ||||
| 4143 | } | ||||||
| 4144 | else { | ||||||
| 4145 | 0 | 0 | err_msg | ||||
| 4146 | "Unexpected $obj->{name} in anchor of $area->{name}"; | ||||||
| 4147 | |||||||
| 4148 | # Prevent further errors. | ||||||
| 4149 | 0 | 0 | delete $area->{anchor}; | ||||
| 4150 | } | ||||||
| 4151 | } | ||||||
| 4152 | else { | ||||||
| 4153 | 0 | 0 | err_msg | ||||
| 4154 | "Expected exactly one element in anchor of $area->{name}"; | ||||||
| 4155 | 0 | 0 | delete $area->{anchor}; | ||||
| 4156 | } | ||||||
| 4157 | |||||||
| 4158 | } | ||||||
| 4159 | else { | ||||||
| 4160 | 49 | 57 | for my $attr (qw(border inclusive_border)) { | ||||
| 4161 | 98 | 200 | next if !$area->{$attr}; | ||||
| 4162 | 52 | 109 | $area->{$attr} = expand_group($area->{$attr}, $area->{name}); | ||||
| 4163 | 52 52 | 82 74 | for my $obj (@{ $area->{$attr} }) { | ||||
| 4164 | 62 | 86 | if (is_interface $obj) { | ||||
| 4165 | 62 | 68 | my $router = $obj->{router}; | ||||
| 4166 | 62 | 103 | $router->{managed} | ||||
| 4167 | or err_msg "Referencing unmanaged $obj->{name} ", | ||||||
| 4168 | "from $area->{name}"; | ||||||
| 4169 | |||||||
| 4170 | # Reverse swapped main and virtual interface. | ||||||
| 4171 | 62 | 172 | if (my $main_interface = $obj->{main_interface}) { | ||||
| 4172 | 2 | 5 | $obj = $main_interface; | ||||
| 4173 | } | ||||||
| 4174 | } | ||||||
| 4175 | else { | ||||||
| 4176 | 0 | 0 | err_msg | ||||
| 4177 | "Unexpected $obj->{name} in $attr of $area->{name}"; | ||||||
| 4178 | |||||||
| 4179 | # Prevent further errors. | ||||||
| 4180 | 0 | 0 | delete $area->{$attr}; | ||||
| 4181 | } | ||||||
| 4182 | } | ||||||
| 4183 | } | ||||||
| 4184 | } | ||||||
| 4185 | 66 | 162 | if (my $router_attributes = $area->{router_attributes}) { | ||||
| 4186 | 7 | 10 | link_policy_distribution_point($router_attributes); | ||||
| 4187 | 7 | 9 | link_general_permit($router_attributes); | ||||
| 4188 | } | ||||||
| 4189 | } | ||||||
| 4190 | 337 | 319 | return; | ||||
| 4191 | } | ||||||
| 4192 | |||||||
| 4193 | # Link interfaces with networks in both directions. | ||||||
| 4194 | sub link_interfaces { | ||||||
| 4195 | 690 | 0 | 586 | my ($router) = @_; | |||
| 4196 | 690 690 | 546 952 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 4197 | 1588 | 1696 | my $net_name = $interface->{network}; | ||||
| 4198 | 1588 | 1827 | my $network = $networks{$net_name}; | ||||
| 4199 | |||||||
| 4200 | 1588 | 2282 | unless ($network) { | ||||
| 4201 | 0 | 0 | my $msg = "Referencing undefined network:$net_name" | ||||
| 4202 | . " from $interface->{name}"; | ||||||
| 4203 | 0 | 0 | if ($interface->{disabled}) { | ||||
| 4204 | 0 | 0 | warn_msg($msg); | ||||
| 4205 | } | ||||||
| 4206 | else { | ||||||
| 4207 | 0 | 0 | err_msg($msg); | ||||
| 4208 | |||||||
| 4209 | # Prevent further errors. | ||||||
| 4210 | 0 | 0 | $interface->{disabled} = 1; | ||||
| 4211 | } | ||||||
| 4212 | |||||||
| 4213 | # Prevent further errors. | ||||||
| 4214 | # This case is handled in disable_behind. | ||||||
| 4215 | 0 | 0 | $interface->{network} = undef; | ||||
| 4216 | 0 | 0 | next; | ||||
| 4217 | } | ||||||
| 4218 | |||||||
| 4219 | 1588 | 1426 | $interface->{network} = $network; | ||||
| 4220 | |||||||
| 4221 | # Private network must be connected to private interface | ||||||
| 4222 | # of same context. | ||||||
| 4223 | 1588 | 2544 | if (my $private1 = $network->{private}) { | ||||
| 4224 | 3 | 4 | if (my $private2 = $interface->{private}) { | ||||
| 4225 | 2 | 10 | $private1 eq $private2 | ||||
| 4226 | or err_msg("$private2.private $interface->{name} must not", | ||||||
| 4227 | " be connected to $private1.private", | ||||||
| 4228 | " $network->{name}"); | ||||||
| 4229 | } | ||||||
| 4230 | else { | ||||||
| 4231 | 1 | 5 | err_msg("Public $interface->{name} must not be connected to", | ||||
| 4232 | " $private1.private $network->{name}"); | ||||||
| 4233 | } | ||||||
| 4234 | } | ||||||
| 4235 | |||||||
| 4236 | # Public network may connect to private interface. | ||||||
| 4237 | # The owner of a private context can prevent a public network from | ||||||
| 4238 | # connecting to a private interface by simply connecting an own private | ||||||
| 4239 | # network to the private interface. | ||||||
| 4240 | |||||||
| 4241 | 1588 1588 | 1141 2252 | push @{ $network->{interfaces} }, $interface; | ||||
| 4242 | 1588 | 1993 | check_interface_ip($interface, $network); | ||||
| 4243 | } | ||||||
| 4244 | 690 | 714 | return; | ||||
| 4245 | } | ||||||
| 4246 | |||||||
| 4247 | sub check_interface_ip { | ||||||
| 4248 | 1608 | 0 | 1344 | my ($interface, $network) = @_; | |||
| 4249 | 1608 | 1513 | my $ip = $interface->{ip}; | ||||
| 4250 | 1608 | 1376 | my $network_ip = $network->{ip}; | ||||
| 4251 | 1608 | 5487 | if ($ip =~ /^(?:short|tunnel)$/) { | ||||
| 4252 | |||||||
| 4253 | # Nothing to check: | ||||||
| 4254 | # short interface may be linked to arbitrary network, | ||||||
| 4255 | # tunnel interfaces and networks have been generated internally. | ||||||
| 4256 | } | ||||||
| 4257 | elsif ($ip eq 'unnumbered') { | ||||||
| 4258 | 13 | 20 | $network_ip eq 'unnumbered' | ||||
| 4259 | or err_msg("Unnumbered $interface->{name} must not be linked ", | ||||||
| 4260 | "to $network->{name}"); | ||||||
| 4261 | } | ||||||
| 4262 | elsif ($network_ip eq 'unnumbered') { | ||||||
| 4263 | 0 | 0 | err_msg("$interface->{name} must not be linked ", | ||||
| 4264 | "to unnumbered $network->{name}"); | ||||||
| 4265 | } | ||||||
| 4266 | elsif ($ip eq 'negotiated') { | ||||||
| 4267 | } | ||||||
| 4268 | elsif ($ip eq 'bridged') { | ||||||
| 4269 | |||||||
| 4270 | # Nothing to be checked: attribute 'bridged' is set automatically | ||||||
| 4271 | # for an interface without IP and linked to bridged network. | ||||||
| 4272 | } | ||||||
| 4273 | else { | ||||||
| 4274 | |||||||
| 4275 | # Check compatibility of interface IP and network IP/mask. | ||||||
| 4276 | 1330 | 1142 | my $mask = $network->{mask}; | ||||
| 4277 | 1330 | 1620 | if (not(match_ip($ip, $network_ip, $mask))) { | ||||
| 4278 | 0 | 0 | err_msg("$interface->{name}'s IP doesn't match ", | ||||
| 4279 | "$network->{name}'s IP/mask"); | ||||||
| 4280 | } | ||||||
| 4281 | 1330 | 1768 | if ($mask == 0xffffffff) { | ||||
| 4282 | 40 | 72 | if (not $network->{loopback}) { | ||||
| 4283 | 1 | 5 | warn_msg("$interface->{name} has address of its network.\n", | ||||
| 4284 | " Remove definition of $network->{name} and\n", | ||||||
| 4285 | " add attribute 'loopback' at", | ||||||
| 4286 | " interface definition."); | ||||||
| 4287 | } | ||||||
| 4288 | } | ||||||
| 4289 | else { | ||||||
| 4290 | 1290 | 2091 | if ($ip == $network_ip) { | ||||
| 4291 | 0 | 0 | err_msg("$interface->{name} has address of its network"); | ||||
| 4292 | } | ||||||
| 4293 | 1290 | 1484 | my $broadcast = $network_ip + complement_32bit $mask; | ||||
| 4294 | 1290 | 1968 | if ($ip == $broadcast) { | ||||
| 4295 | 0 | 0 | err_msg("$interface->{name} has broadcast address"); | ||||
| 4296 | } | ||||||
| 4297 | } | ||||||
| 4298 | } | ||||||
| 4299 | 1608 | 2578 | return; | ||||
| 4300 | } | ||||||
| 4301 | |||||||
| 4302 | # Iterate over all interfaces of all routers. | ||||||
| 4303 | # Don't use values %interfaces because we want to traverse the interfaces | ||||||
| 4304 | # in a deterministic order. | ||||||
| 4305 | sub link_routers { | ||||||
| 4306 | 337 | 0 | 947 | for my $router (sort(by_name values %routers), @router_fragments) { | |||
| 4307 | 690 | 874 | link_interfaces($router); | ||||
| 4308 | 690 | 888 | link_policy_distribution_point($router); | ||||
| 4309 | 690 | 773 | link_general_permit($router); | ||||
| 4310 | } | ||||||
| 4311 | 337 | 341 | return; | ||||
| 4312 | } | ||||||
| 4313 | |||||||
| 4314 | sub link_subnet { | ||||||
| 4315 | 1251 | 0 | 1031 | my ($object, $parent) = @_; | |||
| 4316 | |||||||
| 4317 | my $context = sub { | ||||||
| 4318 | 1 | 7 | !$parent ? $object->{name} | ||||
| 4319 | : ref $parent ? "$object->{name} of $parent->{name}" | ||||||
| 4320 | : "$parent $object->{name}"; | ||||||
| 4321 | 1251 | 2705 | }; | ||||
| 4322 | 1251 | 4258 | return if not $object->{subnet_of}; | ||||
| 4323 | 36 36 | 38 66 | my ($type, $name) = @{ $object->{subnet_of} }; | ||||
| 4324 | 36 | 81 | if ($type ne 'network') { | ||||
| 4325 | 0 | 0 | err_msg "Attribute 'subnet_of' of ", $context->(), "\n", | ||||
| 4326 | " must not be linked to $type:$name"; | ||||||
| 4327 | |||||||
| 4328 | # Prevent further errors; | ||||||
| 4329 | 0 | 0 | delete $object->{subnet_of}; | ||||
| 4330 | 0 | 0 | return; | ||||
| 4331 | } | ||||||
| 4332 | 36 | 49 | my $network = $networks{$name}; | ||||
| 4333 | 36 | 69 | if (not $network) { | ||||
| 4334 | 0 | 0 | warn_msg("Ignoring undefined network:$name", | ||||
| 4335 | " from attribute 'subnet_of'\n of ", $context->()); | ||||||
| 4336 | |||||||
| 4337 | # Prevent further errors; | ||||||
| 4338 | 0 | 0 | delete $object->{subnet_of}; | ||||
| 4339 | 0 | 0 | return; | ||||
| 4340 | } | ||||||
| 4341 | 36 | 40 | $object->{subnet_of} = $network; | ||||
| 4342 | 36 | 56 | my $ip = $network->{ip}; | ||||
| 4343 | 36 | 33 | my $mask = $network->{mask}; | ||||
| 4344 | 36 | 44 | my $sub_ip = $object->{ip}; | ||||
| 4345 | |||||||
| 4346 | # debug($network->{name}) if not defined $ip; | ||||||
| 4347 | 36 | 71 | if ($ip eq 'unnumbered') { | ||||
| 4348 | 0 | 0 | err_msg "Unnumbered $network->{name} must not be referenced from", | ||||
| 4349 | " attribute 'subnet_of'\n of ", $context->(); | ||||||
| 4350 | |||||||
| 4351 | # Prevent further errors; | ||||||
| 4352 | 0 | 0 | delete $object->{subnet_of}; | ||||
| 4353 | 0 | 0 | return; | ||||
| 4354 | } | ||||||
| 4355 | |||||||
| 4356 | # $sub_mask needs not to be tested here, | ||||||
| 4357 | # because it has already been checked for $object. | ||||||
| 4358 | 36 | 53 | if (not(match_ip($sub_ip, $ip, $mask))) { | ||||
| 4359 | 1 | 2 | err_msg $context->(), " is subnet_of $network->{name}", | ||||
| 4360 | " but its IP doesn't match that's IP/mask"; | ||||||
| 4361 | } | ||||||
| 4362 | 36 | 117 | return; | ||||
| 4363 | } | ||||||
| 4364 | |||||||
| 4365 | sub link_subnets { | ||||||
| 4366 | 337 | 0 | 495 | for my $network (values %networks) { | |||
| 4367 | 1115 | 1285 | link_subnet($network, undef); | ||||
| 4368 | } | ||||||
| 4369 | 337 | 637 | for my $obj (values %networks, values %aggregates, values %areas) { | ||||
| 4370 | 1233 | 2036 | my $nat = $obj->{nat} or next; | ||||
| 4371 | 106 106 | 92 162 | for my $nat (values %{ $obj->{nat} }) { | ||||
| 4372 | 136 | 150 | link_subnet($nat, $obj); | ||||
| 4373 | } | ||||||
| 4374 | } | ||||||
| 4375 | 337 | 332 | return; | ||||
| 4376 | } | ||||||
| 4377 | |||||||
| 4378 | my @pathrestrictions; | ||||||
| 4379 | |||||||
| 4380 | sub add_pathrestriction { | ||||||
| 4381 | 28 | 0 | 31 | my ($name, $elements) = @_; | |||
| 4382 | 28 | 34 | my $restrict = new('Pathrestriction', name => $name, elements => $elements); | ||||
| 4383 | 28 | 32 | for my $interface (@$elements) { | ||||
| 4384 | # debug("pathrestriction $name at $interface->{name}"); | ||||||
| 4385 | 59 59 | 42 80 | push @{ $interface->{path_restrict} }, $restrict; | ||||
| 4386 | 59 | 55 | my $router = $interface->{router}; | ||||
| 4387 | 59 | 110 | $router->{managed} or $router->{semi_managed} = 1; | ||||
| 4388 | } | ||||||
| 4389 | 28 | 30 | push @pathrestrictions, $restrict; | ||||
| 4390 | 28 | 29 | return; | ||||
| 4391 | } | ||||||
| 4392 | |||||||
| 4393 | sub link_pathrestrictions { | ||||||
| 4394 | 337 | 0 | 530 | for my $restrict (values %pathrestrictions) { | |||
| 4395 | 29 | 57 | $restrict->{elements} = expand_group $restrict->{elements}, | ||||
| 4396 | $restrict->{name}; | ||||||
| 4397 | 29 | 50 | my $changed; | ||||
| 4398 | 29 | 30 | my $private = my $no_private = $restrict->{private}; | ||||
| 4399 | 29 29 | 29 37 | for my $obj (@{ $restrict->{elements} }) { | ||||
| 4400 | 60 | 77 | if (not is_interface($obj)) { | ||||
| 4401 | 0 | 0 | err_msg("$restrict->{name} must not reference $obj->{name}"); | ||||
| 4402 | 0 | 0 | $obj = undef; | ||||
| 4403 | 0 | 0 | $changed = 1; | ||||
| 4404 | 0 | 0 | next; | ||||
| 4405 | } | ||||||
| 4406 | |||||||
| 4407 | # Add pathrestriction to interface. | ||||||
| 4408 | # Multiple restrictions may be applied to a single | ||||||
| 4409 | # interface. | ||||||
| 4410 | 60 60 | 51 86 | push @{ $obj->{path_restrict} }, $restrict; | ||||
| 4411 | |||||||
| 4412 | # Unmanaged router with pathrestriction is handled specially. | ||||||
| 4413 | # It is separating zones, but gets no code. | ||||||
| 4414 | 60 | 55 | my $router = $obj->{router}; | ||||
| 4415 | 60 | 97 | $router->{managed} or $router->{semi_managed} = 1; | ||||
| 4416 | |||||||
| 4417 | # Pathrestrictions must not be applied to secondary interfaces | ||||||
| 4418 | 60 | 87 | $obj->{main_interface} | ||||
| 4419 | and err_msg "secondary $obj->{name} must not be used", | ||||||
| 4420 | " in pathrestriction"; | ||||||
| 4421 | |||||||
| 4422 | # Private pathrestriction must reference at least one interface | ||||||
| 4423 | # of its own context. | ||||||
| 4424 | 60 | 67 | if ($private) { | ||||
| 4425 | 0 | 0 | if (my $obj_p = $obj->{private}) { | ||||
| 4426 | 0 | 0 | $private eq $obj_p and $no_private = 0; | ||||
| 4427 | } | ||||||
| 4428 | } | ||||||
| 4429 | |||||||
| 4430 | # Public pathrestriction must not reference private interface. | ||||||
| 4431 | else { | ||||||
| 4432 | 60 | 119 | if (my $obj_p = $obj->{private}) { | ||||
| 4433 | 0 | 0 | err_msg "Public $restrict->{name} must not reference", | ||||
| 4434 | " $obj_p.private $obj->{name}"; | ||||||
| 4435 | } | ||||||
| 4436 | } | ||||||
| 4437 | } | ||||||
| 4438 | 29 | 45 | if ($no_private) { | ||||
| 4439 | 0 | 0 | err_msg "$private.private $restrict->{name} must reference", | ||||
| 4440 | " at least one interface out of $private.private"; | ||||||
| 4441 | } | ||||||
| 4442 | 29 | 45 | if ($changed) { | ||||
| 4443 | 0 0 0 | 0 0 0 | $restrict->{elements} = [ grep { $_ } @{ $restrict->{elements} } ]; | ||||
| 4444 | } | ||||||
| 4445 | 29 29 | 23 43 | my $count = @{ $restrict->{elements} }; | ||||
| 4446 | 29 | 64 | if ($count == 1) { | ||||
| 4447 | 0 | 0 | warn_msg("Ignoring $restrict->{name} with only", | ||||
| 4448 | " $restrict->{elements}->[0]->{name}"); | ||||||
| 4449 | 0 | 0 | $restrict->{elements} = []; | ||||
| 4450 | } | ||||||
| 4451 | elsif ($count == 0) { | ||||||
| 4452 | 0 | 0 | warn_msg("Ignoring $restrict->{name} without elements"); | ||||
| 4453 | } | ||||||
| 4454 | |||||||
| 4455 | # Add pathrestriction to tunnel interfaces, | ||||||
| 4456 | # which belong to real interface. | ||||||
| 4457 | # Don't count them as extra elements. | ||||||
| 4458 | 29 29 | 26 40 | for my $interface (@{ $restrict->{elements} }) { | ||||
| 4459 | 60 | 231 | next if not($interface->{spoke} or $interface->{hub}); | ||||
| 4460 | |||||||
| 4461 | # Don't add for no_check interface because traffic would | ||||||
| 4462 | # pass the pathrestriction two times. | ||||||
| 4463 | 0 | 0 | next if $interface->{no_check}; | ||||
| 4464 | 0 | 0 | my $router = $interface->{router}; | ||||
| 4465 | 0 0 | 0 0 | for my $intf (@{ $router->{interfaces} }) { | ||||
| 4466 | 0 | 0 | my $real_intf = $intf->{real_interface}; | ||||
| 4467 | 0 | 0 | next if not $real_intf; | ||||
| 4468 | 0 | 0 | next if not $real_intf eq $interface; | ||||
| 4469 | |||||||
| 4470 | # debug("Adding $restrict->{name} to $intf->{name}"); | ||||||
| 4471 | 0 0 | 0 0 | push @{ $restrict->{elements} }, $intf; | ||||
| 4472 | 0 0 | 0 0 | push @{ $intf->{path_restrict} }, $restrict; | ||||
| 4473 | } | ||||||
| 4474 | } | ||||||
| 4475 | } | ||||||
| 4476 | 337 | 307 | return; | ||||
| 4477 | } | ||||||
| 4478 | |||||||
| 4479 | # Collect groups of virtual interfaces | ||||||
| 4480 | # - be connected to the same network and | ||||||
| 4481 | # - having the same IP address. | ||||||
| 4482 | # Link all virtual interfaces to the group of member interfaces. | ||||||
| 4483 | # Check consistency: | ||||||
| 4484 | # - Member interfaces must use identical protocol and identical ID. | ||||||
| 4485 | # - The same ID must not be used by some other group | ||||||
| 4486 | # - connected to the same network | ||||||
| 4487 | # - emploing the same redundancy type | ||||||
| 4488 | sub link_virtual_interfaces { | ||||||
| 4489 | |||||||
| 4490 | # Collect array of virtual interfaces with same IP at same network. | ||||||
| 4491 | 337 | 0 | 291 | my %net2ip2virtual; | |||
| 4492 | |||||||
| 4493 | # Hash table to look up first virtual interface of a group | ||||||
| 4494 | # inside the same network and using the same ID and type. | ||||||
| 4495 | my %net2id2type2virtual; | ||||||
| 4496 | 337 | 404 | for my $virtual1 (@virtual_interfaces) { | ||||
| 4497 | 72 | 110 | next if $virtual1->{disabled}; | ||||
| 4498 | 72 | 68 | my $ip = $virtual1->{ip}; | ||||
| 4499 | 72 | 67 | my $net = $virtual1->{network}; | ||||
| 4500 | 72 | 171 | my $type1 = $virtual1->{redundancy_type} || ''; | ||||
| 4501 | 72 | 173 | my $id1 = $virtual1->{redundancy_id} || ''; | ||||
| 4502 | 72 | 162 | if (my $interfaces = $net2ip2virtual{$net}->{$ip}) { | ||||
| 4503 | 37 | 33 | my $virtual2 = $interfaces->[0]; | ||||
| 4504 | 37 | 88 | my $type2 = $virtual2->{redundancy_type} || ''; | ||||
| 4505 | 37 | 53 | if ($type1 ne $type2) { | ||||
| 4506 | 0 | 0 | err_msg "Virtual IP: $virtual1->{name} and $virtual2->{name}", | ||||
| 4507 | " use different redundancy protocols"; | ||||||
| 4508 | 0 | 0 | next; | ||||
| 4509 | } | ||||||
| 4510 | 37 | 119 | if (not $id1 eq ($virtual2->{redundancy_id} || '')) { | ||||
| 4511 | 0 | 0 | err_msg "Virtual IP: $virtual1->{name} and $virtual2->{name}", | ||||
| 4512 | " use different ID"; | ||||||
| 4513 | 0 | 0 | next; | ||||
| 4514 | } | ||||||
| 4515 | |||||||
| 4516 | # This changes value of %net2ip2virtual and all attributes | ||||||
| 4517 | # {redundancy_interfaces} where this array is referenced. | ||||||
| 4518 | 37 | 39 | push @$interfaces, $virtual1; | ||||
| 4519 | 37 | 71 | $virtual1->{redundancy_interfaces} = $interfaces; | ||||
| 4520 | } | ||||||
| 4521 | else { | ||||||
| 4522 | 35 | 83 | $net2ip2virtual{$net}->{$ip} = $virtual1->{redundancy_interfaces} = | ||||
| 4523 | [$virtual1]; | ||||||
| 4524 | |||||||
| 4525 | # Check for identical ID used at unrelated virtual interfaces | ||||||
| 4526 | # inside the same network. | ||||||
| 4527 | 35 | 81 | if ($id1) { | ||||
| 4528 | 0 | 0 | if (my $virtual2 = | ||||
| 4529 | $net2id2type2virtual{$net}->{$id1}->{$type1}) | ||||||
| 4530 | { | ||||||
| 4531 | 0 | 0 | err_msg "Virtual IP:", | ||||
| 4532 | " Unrelated $virtual1->{name} and $virtual2->{name}", | ||||||
| 4533 | " use identical ID"; | ||||||
| 4534 | } | ||||||
| 4535 | else { | ||||||
| 4536 | 0 | 0 | $net2id2type2virtual{$net}->{$id1}->{$type1} = $virtual1; | ||||
| 4537 | } | ||||||
| 4538 | } | ||||||
| 4539 | } | ||||||
| 4540 | } | ||||||
| 4541 | |||||||
| 4542 | |||||||
| 4543 | # A virtual interface is used as hop for static routing. | ||||||
| 4544 | # Therefore a network behind this interface must be reachable | ||||||
| 4545 | # via all virtual interfaces of the group. | ||||||
| 4546 | # This can only be guaranteed, if pathrestrictions are identical | ||||||
| 4547 | # at all interfaces. | ||||||
| 4548 | # Exception in routing code: | ||||||
| 4549 | # If the group has ony two interfaces, the one or other physical | ||||||
| 4550 | # interface can be used as hop. | ||||||
| 4551 | 337 | 306 | my %seen; | ||||
| 4552 | 337 | 516 | for my $href (values %net2ip2virtual) { | ||||
| 4553 | 35 | 54 | for my $interfaces (values %$href) { | ||||
| 4554 | 35 | 85 | next if @$interfaces <= 2; | ||||
| 4555 | 4 14 | 7 19 | my @virt_routers = map { $_->{router} } @$interfaces; | ||||
| 4556 | 4 14 | 6 27 | my %routers_hash = map { $_ => $_ } @virt_routers; | ||||
| 4557 | 4 | 6 | for my $router (@virt_routers) { | ||||
| 4558 | 14 14 | 12 16 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 4559 | 55 | 89 | next if $interface->{main_interface}; | ||||
| 4560 | 33 | 54 | my $restricts = $interface->{path_restrict} or next; | ||||
| 4561 | 2 | 2 | for my $restrict (@$restricts) { | ||||
| 4562 | 2 | 6 | next if $seen{$restrict}; | ||||
| 4563 | 2 | 4 | my @restrict_routers = | ||||
| 4564 | 2 | 3 | grep({ $routers_hash{$_} } | ||||
| 4565 | 1 | 2 | map { $_->{router} } | ||||
| 4566 | 1 | 1 | @{ $restrict->{elements} }); | ||||
| 4567 | 1 | 2 | next if @restrict_routers == @virt_routers; | ||||
| 4568 | 1 | 3 | $seen{$restrict} = 1; | ||||
| 4569 | 1 | 1 | my @info; | ||||
| 4570 | 1 | 1 | for my $router (@virt_routers) { | ||||
| 4571 | 3 | 3 | my $info = $router->{name}; | ||||
| 4572 | 3 6 | 2 15 | if (grep { $_ eq $router} @restrict_routers) { | ||||
| 4573 | 1 | 2 | $info .= " has $restrict->{name}"; | ||||
| 4574 | } | ||||||
| 4575 | 3 | 4 | push @info, $info; | ||||
| 4576 | } | ||||||
| 4577 | 1 | 4 | err_msg("Must apply pathrestriction equally to", | ||||
| 4578 | " group of routers with virtual IP:\n", | ||||||
| 4579 | " - ", | ||||||
| 4580 | join("\n - ", @info)); | ||||||
| 4581 | } | ||||||
| 4582 | } | ||||||
| 4583 | } | ||||||
| 4584 | } | ||||||
| 4585 | } | ||||||
| 4586 | |||||||
| 4587 | # Automatically add pathrestriction to interfaces belonging to | ||||||
| 4588 | # $net2ip2virtual, if at least one interface is managed. | ||||||
| 4589 | # Pathrestriction would be useless if all devices are unmanaged. | ||||||
| 4590 | 337 | 494 | for my $href (values %net2ip2virtual) { | ||||
| 4591 | 35 | 39 | for my $interfaces (values %$href) { | ||||
| 4592 | 35 | 35 | for my $interface (@$interfaces) { | ||||
| 4593 | 42 | 38 | my $router = $interface->{router}; | ||||
| 4594 | 42 | 127 | if ($router->{managed} || $router->{routing_only}) { | ||||
| 4595 | 28 | 46 | my $name = "auto-virtual-" . print_ip $interface->{ip}; | ||||
| 4596 | 28 | 45 | add_pathrestriction($name, $interfaces); | ||||
| 4597 | 28 | 57 | last; | ||||
| 4598 | } | ||||||
| 4599 | } | ||||||
| 4600 | } | ||||||
| 4601 | } | ||||||
| 4602 | 337 | 514 | return; | ||||
| 4603 | } | ||||||
| 4604 | |||||||
| 4605 | sub check_ip_addresses { | ||||||
| 4606 | 337 | 0 | 500 | for my $network (values %networks) { | |||
| 4607 | 1115 11 | 2354 29 | if ( $network->{ip} eq 'unnumbered' | ||||
| 4608 | and $network->{interfaces} | ||||||
| 4609 | and @{ $network->{interfaces} } > 2) | ||||||
| 4610 | { | ||||||
| 4611 | 0 | 0 | my $msg = "Unnumbered $network->{name} is connected to" | ||||
| 4612 | . " more than two interfaces:"; | ||||||
| 4613 | 0 0 | 0 0 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 4614 | 0 | 0 | $msg .= "\n $interface->{name}"; | ||||
| 4615 | } | ||||||
| 4616 | 0 | 0 | err_msg($msg); | ||||
| 4617 | } | ||||||
| 4618 | |||||||
| 4619 | 1115 | 835 | my %ip2obj; | ||||
| 4620 | |||||||
| 4621 | # 1. Check for duplicate interface addresses. | ||||||
| 4622 | # 2. Short interfaces must not be used, if a managed interface | ||||||
| 4623 | # with static routing exists in the same network. | ||||||
| 4624 | 1115 | 801 | my ($short_intf, $route_intf); | ||||
| 4625 | 1115 1115 | 835 1362 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 4626 | 1633 | 1545 | my $ip = $interface->{ip}; | ||||
| 4627 | 1633 | 1872 | if ($ip eq 'short') { | ||||
| 4628 | |||||||
| 4629 | # Ignore short interface from splitted crypto router. | ||||||
| 4630 | 223 223 | 179 413 | if (1 < @{ $interface->{router}->{interfaces} }) { | ||||
| 4631 | 208 | 183 | $short_intf = $interface; | ||||
| 4632 | } | ||||||
| 4633 | } | ||||||
| 4634 | else { | ||||||
| 4635 | 1410 | 2724 | unless ($ip =~ /^(?:unnumbered|negotiated|tunnel|bridged)$/) { | ||||
| 4636 | 1330 | 1137 | my $router = $interface->{router}; | ||||
| 4637 | 1330 | 4772 | if (($router->{managed} || $router->{routing_only}) | ||||
| 4638 | && !$interface->{routing}) | ||||||
| 4639 | { | ||||||
| 4640 | 713 | 606 | $route_intf = $interface; | ||||
| 4641 | } | ||||||
| 4642 | 1330 | 1750 | if (my $old_intf = $ip2obj{$ip}) { | ||||
| 4643 | 39 | 140 | unless ($old_intf->{redundant} | ||||
| 4644 | and $interface->{redundant}) | ||||||
| 4645 | { | ||||||
| 4646 | 2 | 9 | err_msg "Duplicate IP address for", | ||||
| 4647 | " $old_intf->{name} and $interface->{name}"; | ||||||
| 4648 | } | ||||||
| 4649 | } | ||||||
| 4650 | else { | ||||||
| 4651 | 1291 | 1887 | $ip2obj{$ip} = $interface; | ||||
| 4652 | } | ||||||
| 4653 | } | ||||||
| 4654 | } | ||||||
| 4655 | 1633 | 3748 | if ($short_intf and $route_intf) { | ||||
| 4656 | 1 | 6 | err_msg "$short_intf->{name} must be defined in more detail,", | ||||
| 4657 | " since there is\n", | ||||||
| 4658 | " a managed $route_intf->{name} with static routing enabled."; | ||||||
| 4659 | } | ||||||
| 4660 | } | ||||||
| 4661 | 1115 | 1022 | my %range2obj; | ||||
| 4662 | 1115 1115 | 795 1427 | for my $host (@{ $network->{hosts} }) { | ||||
| 4663 | 181 | 331 | if (my $ip = $host->{ip}) { | ||||
| 4664 | 160 | 272 | if (my $other_device = $ip2obj{$ip}) { | ||||
| 4665 | 4 | 15 | err_msg "Duplicate IP address for $other_device->{name}", | ||||
| 4666 | " and $host->{name}"; | ||||||
| 4667 | } | ||||||
| 4668 | else { | ||||||
| 4669 | 156 | 288 | $ip2obj{$ip} = $host; | ||||
| 4670 | } | ||||||
| 4671 | } | ||||||
| 4672 | elsif (my $range = $host->{range}) { | ||||||
| 4673 | 21 | 24 | my ($from, $to) = @$range; | ||||
| 4674 | 21 | 57 | if (my $other_device = $range2obj{$from}->{$to}) { | ||||
| 4675 | 1 | 4 | err_msg "Duplicate IP range for $other_device->{name}", | ||||
| 4676 | " and $host->{name}"; | ||||||
| 4677 | } | ||||||
| 4678 | else { | ||||||
| 4679 | 20 | 41 | $range2obj{$from}->{$to} = $host; | ||||
| 4680 | } | ||||||
| 4681 | } | ||||||
| 4682 | } | ||||||
| 4683 | 1115 1115 | 878 2075 | for my $host (@{ $network->{hosts} }) { | ||||
| 4684 | 181 | 535 | if (my $range = $host->{range}) { | ||||
| 4685 | 21 | 39 | for (my $ip = $range->[0] ; $ip <= $range->[1] ; $ip++) { | ||||
| 4686 | 774 | 1615 | if (my $other_device = $ip2obj{$ip}) { | ||||
| 4687 | 5 | 6 | is_host($other_device) | ||||
| 4688 | or err_msg("Duplicate IP address for", | ||||||
| 4689 | " $other_device->{name}", | ||||||
| 4690 | " and $host->{name}"); | ||||||
| 4691 | } | ||||||
| 4692 | } | ||||||
| 4693 | } | ||||||
| 4694 | } | ||||||
| 4695 | } | ||||||
| 4696 | 337 | 357 | return; | ||||
| 4697 | } | ||||||
| 4698 | |||||||
| 4699 | sub link_ipsec; | ||||||
| 4700 | sub link_crypto; | ||||||
| 4701 | sub link_tunnels; | ||||||
| 4702 | |||||||
| 4703 | sub link_topology { | ||||||
| 4704 | 337 | 0 | 474 | progress('Linking topology'); | |||
| 4705 | 337 | 465 | link_routers; | ||||
| 4706 | 337 | 487 | link_ipsec; | ||||
| 4707 | 337 | 459 | link_crypto; | ||||
| 4708 | 337 | 455 | link_tunnels; | ||||
| 4709 | 337 | 476 | link_pathrestrictions; | ||||
| 4710 | 337 | 435 | link_virtual_interfaces; | ||||
| 4711 | 337 | 452 | link_areas; | ||||
| 4712 | 337 | 445 | link_subnets; | ||||
| 4713 | 337 | 478 | link_owners; | ||||
| 4714 | 337 | 439 | check_ip_addresses(); | ||||
| 4715 | 337 | 302 | return; | ||||
| 4716 | } | ||||||
| 4717 | |||||||
| 4718 | #################################################################### | ||||||
| 4719 | # Mark all parts of the topology located behind disabled interfaces. | ||||||
| 4720 | # "Behind" is defined like this: | ||||||
| 4721 | # Look from a router to its interfaces; | ||||||
| 4722 | # if an interface is marked as disabled, | ||||||
| 4723 | # recursively mark the whole part of the topology located behind | ||||||
| 4724 | # this interface as disabled. | ||||||
| 4725 | # Be cautious with loops: | ||||||
| 4726 | # Mark all interfaces at loop entry as disabled, | ||||||
| 4727 | # otherwise the whole topology will get disabled. | ||||||
| 4728 | #################################################################### | ||||||
| 4729 | |||||||
| 4730 | sub disable_behind; | ||||||
| 4731 | |||||||
| 4732 | sub disable_behind { | ||||||
| 4733 | 3 | 0 | 3 | my ($in_interface) = @_; | |||
| 4734 | |||||||
| 4735 | # debug("disable_behind $in_interface->{name}"); | ||||||
| 4736 | 3 | 5 | $in_interface->{disabled} = 1; | ||||
| 4737 | 3 | 2 | my $network = $in_interface->{network}; | ||||
| 4738 | 3 | 13 | if (not $network or $network->{disabled}) { | ||||
| 4739 | |||||||
| 4740 | # debug("Stop disabling at $network->{name}"); | ||||||
| 4741 | 1 | 2 | return; | ||||
| 4742 | } | ||||||
| 4743 | 2 | 3 | $network->{disabled} = 1; | ||||
| 4744 | 2 2 | 3 3 | for my $host (@{ $network->{hosts} }) { | ||||
| 4745 | 1 | 2 | $host->{disabled} = 1; | ||||
| 4746 | } | ||||||
| 4747 | 2 2 | 2 4 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 4748 | 3 | 8 | next if $interface eq $in_interface; | ||||
| 4749 | |||||||
| 4750 | # This stops at other entry of a loop as well. | ||||||
| 4751 | 1 | 2 | if ($interface->{disabled}) { | ||||
| 4752 | |||||||
| 4753 | # debug("Stop disabling at $interface->{name}"); | ||||||
| 4754 | 1 | 2 | next; | ||||
| 4755 | } | ||||||
| 4756 | 0 | 0 | $interface->{disabled} = 1; | ||||
| 4757 | 0 | 0 | my $router = $interface->{router}; | ||||
| 4758 | 0 | 0 | $router->{disabled} = 1; | ||||
| 4759 | 0 0 | 0 0 | for my $out_interface (@{ $router->{interfaces} }) { | ||||
| 4760 | 0 | 0 | next if $out_interface eq $interface; | ||||
| 4761 | 0 | 0 | disable_behind $out_interface ; | ||||
| 4762 | } | ||||||
| 4763 | } | ||||||
| 4764 | 2 | 3 | return; | ||||
| 4765 | } | ||||||
| 4766 | |||||||
| 4767 | # Lists of network objects which are left over after disabling. | ||||||
| 4768 | #my @managed_routers; # defined above | ||||||
| 4769 | my @routing_only_routers; | ||||||
| 4770 | my @managed_crypto_hubs; | ||||||
| 4771 | my @routers; | ||||||
| 4772 | my @networks; | ||||||
| 4773 | my @zones; | ||||||
| 4774 | my @areas; | ||||||
| 4775 | |||||||
| 4776 | # Group bridged networks by prefix of name. | ||||||
| 4777 | # Each group | ||||||
| 4778 | # - must have the same IP address and mask, | ||||||
| 4779 | # - must have at least two members, | ||||||
| 4780 | # - must be adjacent | ||||||
| 4781 | # - linked by bridged interfaces | ||||||
| 4782 | # - IP addresses of hosts must be disjoint (ToDo). | ||||||
| 4783 | # Each router having a bridged interface | ||||||
| 4784 | # must connect at least two bridged networks of the same group. | ||||||
| 4785 | sub check_bridged_networks { | ||||||
| 4786 | 337 | 0 | 290 | my %prefix2net; | |||
| 4787 | 337 | 366 | for my $network (@networks) { | ||||
| 4788 | 1112 | 1902 | my $prefix = $network->{bridged} or next; | ||||
| 4789 | 14 | 32 | $prefix2net{$prefix}->{$network} = $network; | ||||
| 4790 | } | ||||||
| 4791 | 337 | 593 | for my $prefix (keys %prefix2net) { | ||||
| 4792 | 7 | 20 | if (my $network = $networks{$prefix}) { | ||||
| 4793 | 0 | 0 | $network->{disabled} | ||||
| 4794 | or err_msg("Must not define $network->{name} together with", | ||||||
| 4795 | " bridged networks of same name"); | ||||||
| 4796 | } | ||||||
| 4797 | } | ||||||
| 4798 | 337 | 499 | for my $href (values %prefix2net) { | ||||
| 4799 | 7 | 13 | my @group = values %$href; | ||||
| 4800 | 7 | 8 | my $net1 = pop(@group); | ||||
| 4801 | 7 | 11 | @group or warn_msg("Bridged $net1->{name} must not be used solitary"); | ||||
| 4802 | 7 | 8 | my %seen; | ||||
| 4803 | 7 | 8 | my @next = ($net1); | ||||
| 4804 | 7 7 | 6 14 | my ($ip1, $mask1) = @{$net1}{qw(ip mask)}; | ||||
| 4805 | |||||||
| 4806 | # Mark all networks connected directly or indirectly with $net1 | ||||||
| 4807 | # by a bridge as 'connected' in $href. | ||||||
| 4808 | 7 | 14 | while (my $network = pop(@next)) { | ||||
| 4809 | 14 14 | 14 17 | my ($ip, $mask) = @{$network}{qw(ip mask)}; | ||||
| 4810 | 14 | 46 | $ip == $ip1 and $mask == $mask1 | ||||
| 4811 | or err_msg("$net1->{name} and $network->{name} must have", | ||||||
| 4812 | " identical ip/mask"); | ||||||
| 4813 | 14 | 23 | $href->{$network} = 'connected'; | ||||
| 4814 | 14 14 | 9 18 | for my $in_intf (@{ $network->{interfaces} }) { | ||||
| 4815 | 24 | 54 | next if $in_intf->{ip} ne 'bridged'; | ||||
| 4816 | 14 | 13 | my $router = $in_intf->{router}; | ||||
| 4817 | 14 | 39 | next if $seen{$router}; | ||||
| 4818 | 7 | 4 | my $count = 1; | ||||
| 4819 | 7 | 12 | $seen{$router} = $router; | ||||
| 4820 | 7 | 13 | if (my $layer3_intf = $in_intf->{layer3_interface}) { | ||||
| 4821 | 7 | 14 | match_ip($layer3_intf->{ip}, $ip, $mask) | ||||
| 4822 | or err_msg("$layer3_intf->{name}'s IP doesn't match", | ||||||
| 4823 | " IP/mask of bridged networks"); | ||||||
| 4824 | } | ||||||
| 4825 | 7 7 | 7 12 | for my $out_intf (@{ $router->{interfaces} }) { | ||||
| 4826 | 21 | 41 | next if $out_intf eq $in_intf; | ||||
| 4827 | 14 | 26 | next if $out_intf->{ip} ne 'bridged'; | ||||
| 4828 | 7 | 9 | my $next_net = $out_intf->{network}; | ||||
| 4829 | 7 | 13 | next if not $href->{$next_net}; | ||||
| 4830 | 7 | 7 | push(@next, $out_intf->{network}); | ||||
| 4831 | 7 | 14 | $count++; | ||||
| 4832 | } | ||||||
| 4833 | 7 | 23 | $count > 1 | ||||
| 4834 | or err_msg("$router->{name} can't bridge a single network"); | ||||||
| 4835 | } | ||||||
| 4836 | } | ||||||
| 4837 | 7 | 7 | for my $network (@group) { | ||||
| 4838 | 7 | 31 | $href->{$network} eq 'connected' | ||||
| 4839 | or err_msg( | ||||||
| 4840 | "$network->{name} and $net1->{name}", | ||||||
| 4841 | " must be connected by bridge" | ||||||
| 4842 | ); | ||||||
| 4843 | } | ||||||
| 4844 | } | ||||||
| 4845 | 337 | 434 | return; | ||||
| 4846 | } | ||||||
| 4847 | |||||||
| 4848 | sub mark_disabled { | ||||||
| 4849 | 337 1585 | 0 | 560 1749 | my @disabled_interfaces = grep { $_->{disabled} } values %interfaces; | |||
| 4850 | |||||||
| 4851 | 337 | 417 | for my $interface (@disabled_interfaces) { | ||||
| 4852 | 3 | 7 | next if $interface->{router}->{disabled}; | ||||
| 4853 | 3 | 6 | disable_behind($interface); | ||||
| 4854 | 3 | 8 | if ($interface->{router}->{disabled}) { | ||||
| 4855 | |||||||
| 4856 | # We reached an initial element of @disabled_interfaces, | ||||||
| 4857 | # which seems to be part of a loop. | ||||||
| 4858 | # This is dangerous, since the whole topology | ||||||
| 4859 | # may be disabled by accident. | ||||||
| 4860 | 0 | 0 | err_msg "$interface->{name} must not be disabled,\n", | ||||
| 4861 | " since it is part of a loop"; | ||||||
| 4862 | } | ||||||
| 4863 | } | ||||||
| 4864 | 337 | 401 | for my $interface (@disabled_interfaces) { | ||||
| 4865 | |||||||
| 4866 | # Delete disabled interfaces from routers. | ||||||
| 4867 | 3 | 4 | my $router = $interface->{router}; | ||||
| 4868 | 3 | 5 | aref_delete($router->{interfaces}, $interface); | ||||
| 4869 | 3 | 8 | if ($router->{managed} || $router->{routing_only}) { | ||||
| 4870 | 3 | 5 | aref_delete($interface->{hardware}->{interfaces}, $interface); | ||||
| 4871 | } | ||||||
| 4872 | } | ||||||
| 4873 | |||||||
| 4874 | # Disable area, where all interfaces or anchor are disabled. | ||||||
| 4875 | 337 | 790 | for my $area (sort by_name values %areas) { | ||||
| 4876 | 66 | 61 | my $ok; | ||||
| 4877 | 66 | 116 | if (my $anchor = $area->{anchor}) { | ||||
| 4878 | 17 | 23 | $ok = !$anchor->{disabled}; | ||||
| 4879 | } | ||||||
| 4880 | else { | ||||||
| 4881 | 49 | 58 | for my $attr (qw(border inclusive_border)) { | ||||
| 4882 | 98 | 206 | my $borders = $area->{$attr} or next; | ||||
| 4883 | 52 62 | 70 163 | if (my @active_borders = grep { !$_->{disabled} } @$borders) { | ||||
| 4884 | 52 | 65 | $area->{$attr} = \@active_borders; | ||||
| 4885 | 52 | 75 | $ok = 1; | ||||
| 4886 | } | ||||||
| 4887 | } | ||||||
| 4888 | } | ||||||
| 4889 | 66 | 108 | if ($ok) { | ||||
| 4890 | 66 | 109 | push @areas, $area; | ||||
| 4891 | } | ||||||
| 4892 | else { | ||||||
| 4893 | 0 | 0 | $area->{disabled} = 1; | ||||
| 4894 | } | ||||||
| 4895 | } | ||||||
| 4896 | |||||||
| 4897 | 337 | 735 | for my $router (sort(by_name values %routers), @router_fragments) { | ||||
| 4898 | 690 | 1080 | next if $router->{disabled}; | ||||
| 4899 | 690 | 602 | push @routers, $router; | ||||
| 4900 | 690 | 1152 | if ($router->{managed}) { | ||||
| 4901 | 465 | 581 | push @managed_routers, $router; | ||||
| 4902 | } | ||||||
| 4903 | elsif ($router->{routing_only}) { | ||||||
| 4904 | 6 | 8 | push @routing_only_routers, $router; | ||||
| 4905 | } | ||||||
| 4906 | } | ||||||
| 4907 | |||||||
| 4908 | # Collect vrf instances belonging to one device. | ||||||
| 4909 | # This includes different managed hosts with identical server_name. | ||||||
| 4910 | 337 | 318 | my %name2vrf; | ||||
| 4911 | 337 | 395 | for my $router (@managed_routers, @routing_only_routers) { | ||||
| 4912 | 491 | 751 | next if $router->{orig_router}; | ||||
| 4913 | 473 | 497 | my $device_name = $router->{device_name}; | ||||
| 4914 | 473 473 | 351 1026 | push @{ $name2vrf{$device_name} }, $router; | ||||
| 4915 | } | ||||||
| 4916 | 337 | 507 | for my $aref (values %name2vrf) { | ||||
| 4917 | 469 | 899 | next if @$aref == 1; | ||||
| 4918 | 4 8 | 5 34 | equal(map { $_->{managed} || $_->{routing_only} | ||||
| 4919 | ? $_->{model}->{name} | ||||||
| 4920 | : () } | ||||||
| 4921 | @$aref) | ||||||
| 4922 | or err_msg("All VRF instances of router:$aref->[0]->{device_name}", | ||||||
| 4923 | " must have identical model"); | ||||||
| 4924 | |||||||
| 4925 | 4 | 7 | my %hardware; | ||||
| 4926 | 4 | 5 | for my $router (@$aref) { | ||||
| 4927 | 8 8 | 6 11 | for my $hardware (@{ $router->{hardware} }) { | ||||
| 4928 | 14 | 17 | my $name = $hardware->{name}; | ||||
| 4929 | 14 | 19 | if (my $other = $hardware{$name}) { | ||||
| 4930 | 0 | 0 | err_msg( | ||||
| 4931 | "Duplicate hardware '$name' at", | ||||||
| 4932 | " $other->{name} and $router->{name}" | ||||||
| 4933 | ); | ||||||
| 4934 | } | ||||||
| 4935 | else { | ||||||
| 4936 | 14 | 28 | $hardware{$name} = $router; | ||||
| 4937 | } | ||||||
| 4938 | } | ||||||
| 4939 | } | ||||||
| 4940 | 4 | 6 | my $shared_hash = {}; | ||||
| 4941 | 4 | 8 | for my $router (@$aref) { | ||||
| 4942 | 8 | 9 | $router->{vrf_members} = $aref; | ||||
| 4943 | 8 | 16 | $router->{vrf_shared_data} = $shared_hash; | ||||
| 4944 | } | ||||||
| 4945 | } | ||||||
| 4946 | |||||||
| 4947 | # Collect networks into @networks. | ||||||
| 4948 | # We need a deterministic order. | ||||||
| 4949 | # Don't sort by name because code shouldn't change if a network is renamed. | ||||||
| 4950 | # Derive order from order of routers and interfaces. | ||||||
| 4951 | 337 | 304 | my %seen; | ||||
| 4952 | 337 | 353 | for my $router (@routers) { | ||||
| 4953 | 690 690 | 530 848 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 4954 | 1610 | 2175 | next if $interface->{disabled}; | ||||
| 4955 | 1610 | 1323 | my $network = $interface->{network}; | ||||
| 4956 | 1610 | 4425 | $seen{$network}++ or push @networks, $network; | ||||
| 4957 | } | ||||||
| 4958 | } | ||||||
| 4959 | |||||||
| 4960 | # Find networks not connected to any router. | ||||||
| 4961 | 337 | 533 | for my $network (values %networks) { | ||||
| 4962 | 1115 | 1508 | next if $network->{disabled}; | ||||
| 4963 | 1113 | 2180 | if (! $seen{$network}) { | ||||
| 4964 | 20 | 36 | if (keys %networks > 1) { | ||||
| 4965 | 1 | 3 | err_msg("$network->{name} isn't connected to any router"); | ||||
| 4966 | 1 | 3 | $network->{disabled} = 1; | ||||
| 4967 | } | ||||||
| 4968 | else { | ||||||
| 4969 | 19 | 35 | push @networks, $network; | ||||
| 4970 | } | ||||||
| 4971 | } | ||||||
| 4972 | } | ||||||
| 4973 | |||||||
| 4974 | 337 72 | 446 112 | @virtual_interfaces = grep { not $_->{disabled} } @virtual_interfaces; | ||||
| 4975 | 337 | 476 | check_bridged_networks(); | ||||
| 4976 | 337 | 702 | return; | ||||
| 4977 | } | ||||||
| 4978 | |||||||
| 4979 | #################################################################### | ||||||
| 4980 | # Convert hosts to subnets. | ||||||
| 4981 | # Find adjacent subnets. | ||||||
| 4982 | # Mark subnet relation of subnets. | ||||||
| 4983 | #################################################################### | ||||||
| 4984 | |||||||
| 4985 | # 255.255.255.255, 127.255.255.255, ..., 0.0.0.3, 0.0.0.1, 0.0.0.0 | ||||||
| 4986 | my @inverse_masks = map { complement_32bit prefix2mask $_ } (0 .. 32); | ||||||
| 4987 | |||||||
| 4988 | # Convert an IP range to a set of covering IP/mask pairs. | ||||||
| 4989 | sub split_ip_range { | ||||||
| 4990 | 21 | 0 | 20 | my ($low, $high) = @_; | |||
| 4991 | 21 | 19 | my @result; | ||||
| 4992 | IP: | ||||||
| 4993 | 21 | 34 | while ($low <= $high) { | ||||
| 4994 | 39 | 41 | for my $mask (@inverse_masks) { | ||||
| 4995 | 1200 | 1916 | if (($low & $mask) == 0 && ($low + $mask) <= $high) { | ||||
| 4996 | 39 | 51 | push @result, [ $low, complement_32bit $mask ]; | ||||
| 4997 | 39 | 37 | $low = $low + $mask + 1; | ||||
| 4998 | 39 | 72 | next IP; | ||||
| 4999 | } | ||||||
| 5000 | } | ||||||
| 5001 | } | ||||||
| 5002 | 21 | 35 | return @result; | ||||
| 5003 | } | ||||||
| 5004 | |||||||
| 5005 | sub convert_hosts { | ||||||
| 5006 | 321 | 0 | 415 | progress('Converting hosts to subnets'); | |||
| 5007 | 321 | 361 | for my $network (@networks) { | ||||
| 5008 | 1180 | 2506 | next if $network->{ip} =~ /^(?:unnumbered|tunnel)$/; | ||||
| 5009 | 1147 | 819 | my @inv_prefix_aref; | ||||
| 5010 | |||||||
| 5011 | # Converts hosts and ranges to subnets. | ||||||
| 5012 | # Eliminate duplicate subnets. | ||||||
| 5013 | 1147 1147 | 858 1496 | for my $host (@{ $network->{hosts} }) { | ||||
| 5014 | 174 | 313 | my ($name, $nat, $id, $private, $owner) = | ||||
| 5015 | 174 | 184 | @{$host}{qw(name nat id private owner)}; | ||||
| 5016 | 174 | 159 | my @ip_mask; | ||||
| 5017 | 174 | 312 | if (my $ip = $host->{ip}) { | ||||
| 5018 | 153 | 246 | @ip_mask = [ $ip, 0xffffffff ]; | ||||
| 5019 | 153 | 264 | if ($id) { | ||||
| 5020 | 15 | 78 | if (my ($user, $dom) = ($id =~ /^(.*?)(\@.*)$/)) { | ||||
| 5021 | 14 | 36 | $user or err_msg("ID of $name must not start", | ||||
| 5022 | " with character '\@'"); | ||||||
| 5023 | } | ||||||
| 5024 | else { | ||||||
| 5025 | 1 | 3 | err_msg("ID of $name must contain character '\@'"); | ||||
| 5026 | } | ||||||
| 5027 | } | ||||||
| 5028 | } | ||||||
| 5029 | elsif ($host->{range}) { | ||||||
| 5030 | 21 21 | 21 28 | my ($ip1, $ip2) = @{ $host->{range} }; | ||||
| 5031 | 21 | 36 | @ip_mask = split_ip_range $ip1, $ip2; | ||||
| 5032 | 21 | 39 | if ($id) { | ||||
| 5033 | 11 | 40 | if (@ip_mask > 1) { | ||||
| 5034 | 1 | 4 | err_msg("Range of $name with ID must expand to", | ||||
| 5035 | " exactly one subnet"); | ||||||
| 5036 | } | ||||||
| 5037 | elsif ($ip_mask[0]->[1] == 0xffffffff) { | ||||||
| 5038 | 1 | 3 | err_msg("$name with ID must not have single IP"); | ||||
| 5039 | } | ||||||
| 5040 | elsif ($id =~ /^.+\@/) { | ||||||
| 5041 | 1 | 3 | err_msg("ID of $name must start with character '\@'", | ||||
| 5042 | " or have no '\@' at all"); | ||||||
| 5043 | } | ||||||
| 5044 | } | ||||||
| 5045 | } | ||||||
| 5046 | else { | ||||||
| 5047 | 0 | 0 | internal_err("unexpected host type"); | ||||
| 5048 | } | ||||||
| 5049 | 174 | 199 | for my $ip_mask (@ip_mask) { | ||||
| 5050 | 192 | 213 | my ($ip, $mask) = @$ip_mask; | ||||
| 5051 | 192 | 257 | my $inv_prefix = 32 - mask2prefix $mask; | ||||
| 5052 | 192 | 417 | if (my $other_subnet = $inv_prefix_aref[$inv_prefix]->{$ip}) { | ||||
| 5053 | 4 | 7 | my $nat2 = $other_subnet->{nat}; | ||||
| 5054 | 4 | 2 | my $nat_error; | ||||
| 5055 | 4 | 33 | if ($nat xor $nat2) { | ||||
| 5056 | 0 | 0 | $nat_error = 1; | ||||
| 5057 | } | ||||||
| 5058 | elsif ($nat and $nat2) { | ||||||
| 5059 | |||||||
| 5060 | # Number of entries is equal. | ||||||
| 5061 | 0 | 0 | if (keys %$nat == keys %$nat2) { | ||||
| 5062 | |||||||
| 5063 | # Entries are equal. | ||||||
| 5064 | 0 | 0 | for my $name (keys %$nat) { | ||||
| 5065 | 0 | 0 | unless ($nat2->{$name} | ||||
| 5066 | and $nat->{$name} eq $nat2->{$name}) | ||||||
| 5067 | { | ||||||
| 5068 | 0 | 0 | $nat_error = 1; | ||||
| 5069 | 0 | 0 | last; | ||||
| 5070 | } | ||||||
| 5071 | } | ||||||
| 5072 | } | ||||||
| 5073 | else { | ||||||
| 5074 | 0 | 0 | $nat_error = 1; | ||||
| 5075 | } | ||||||
| 5076 | } | ||||||
| 5077 | $nat_error | ||||||
| 5078 | 4 | 7 | and err_msg "Inconsistent NAT definition for", | ||||
| 5079 | " $other_subnet->{name} and $host->{name}"; | ||||||
| 5080 | |||||||
| 5081 | 4 | 4 | my $owner2 = $other_subnet->{owner}; | ||||
| 5082 | 4 | 21 | if (($owner xor $owner2) | ||||
| 5083 | || $owner && $owner2 && $owner ne $owner2) | ||||||
| 5084 | { | ||||||
| 5085 | 0 | 0 | err_msg "Inconsistent owner definition for", | ||||
| 5086 | " $other_subnet->{name} and $host->{name}"; | ||||||
| 5087 | } | ||||||
| 5088 | 4 4 | 3 15 | push @{ $host->{subnets} }, $other_subnet; | ||||
| 5089 | } | ||||||
| 5090 | else { | ||||||
| 5091 | 188 | 287 | my $subnet = new( | ||||
| 5092 | 'Subnet', | ||||||
| 5093 | name => $name, | ||||||
| 5094 | network => $network, | ||||||
| 5095 | ip => $ip, | ||||||
| 5096 | mask => $mask, | ||||||
| 5097 | ); | ||||||
| 5098 | 188 | 301 | $subnet->{nat} = $nat if $nat; | ||||
| 5099 | 188 | 266 | $subnet->{private} = $private if $private; | ||||
| 5100 | 188 | 274 | $subnet->{owner} = $owner if $owner; | ||||
| 5101 | 188 | 260 | if ($id) { | ||||
| 5102 | 30 | 32 | $subnet->{id} = $id; | ||||
| 5103 | 30 | 37 | $subnet->{radius_attributes} = | ||||
| 5104 | $host->{radius_attributes}; | ||||||
| 5105 | } | ||||||
| 5106 | 188 | 264 | $inv_prefix_aref[$inv_prefix]->{$ip} = $subnet; | ||||
| 5107 | 188 188 | 151 288 | push @{ $host->{subnets} }, $subnet; | ||||
| 5108 | 188 188 | 162 594 | push @{ $network->{subnets} }, $subnet; | ||||
| 5109 | } | ||||||
| 5110 | } | ||||||
| 5111 | } | ||||||
| 5112 | |||||||
| 5113 | # Find adjacent subnets which build a larger subnet. | ||||||
| 5114 | 1147 | 1563 | my $network_inv_prefix = 32 - mask2prefix $network->{mask}; | ||||
| 5115 | 1147 | 1981 | for (my $i = 0 ; $i < @inv_prefix_aref ; $i++) { | ||||
| 5116 | 189 | 346 | if (my $ip2subnet = $inv_prefix_aref[$i]) { | ||||
| 5117 | 163 | 205 | my $next = 2**$i; | ||||
| 5118 | 163 | 225 | my $modulo = 2 * $next; | ||||
| 5119 | 163 | 306 | for my $ip (keys %$ip2subnet) { | ||||
| 5120 | 196 | 189 | my $subnet = $ip2subnet->{$ip}; | ||||
| 5121 | |||||||
| 5122 | 196 | 1100 | if ( | ||||
| 5123 | |||||||
| 5124 | # Don't combine subnets with NAT | ||||||
| 5125 | # ToDo: This would be possible if all NAT addresses | ||||||
| 5126 | # match too. | ||||||
| 5127 | # But, attention for PIX firewalls: | ||||||
| 5128 | # static commands for networks / subnets block | ||||||
| 5129 | # network and broadcast address. | ||||||
| 5130 | not $subnet->{nat} | ||||||
| 5131 | |||||||
| 5132 | # Don't combine subnets having radius-ID. | ||||||
| 5133 | and not $subnet->{id} | ||||||
| 5134 | |||||||
| 5135 | # Only take the left part of two adjacent subnets. | ||||||
| 5136 | and $ip % $modulo == 0 | ||||||
| 5137 | ) | ||||||
| 5138 | { | ||||||
| 5139 | 101 | 101 | my $next_ip = $ip + $next; | ||||
| 5140 | |||||||
| 5141 | # Find the right part. | ||||||
| 5142 | 101 | 216 | if (my $neighbor = $ip2subnet->{$next_ip}) { | ||||
| 5143 | 8 | 11 | $subnet->{neighbor} = $neighbor; | ||||
| 5144 | 8 | 8 | my $up_inv_prefix = $i + 1; | ||||
| 5145 | 8 | 6 | my $up; | ||||
| 5146 | 8 | 35 | if ($up_inv_prefix >= $network_inv_prefix) { | ||||
| 5147 | |||||||
| 5148 | # Larger subnet is whole network. | ||||||
| 5149 | 0 | 0 | $up = $network; | ||||
| 5150 | } | ||||||
| 5151 | elsif ( $up_inv_prefix < @inv_prefix_aref | ||||||
| 5152 | and $up = | ||||||
| 5153 | $inv_prefix_aref[$up_inv_prefix]->{$ip}) | ||||||
| 5154 | { | ||||||
| 5155 | } | ||||||
| 5156 | else { | ||||||
| 5157 | 8 | 41 | (my $name = $subnet->{name}) =~ | ||||
| 5158 | s/^.*:/auto_subnet:/; | ||||||
| 5159 | 8 | 17 | my $mask = prefix2mask(32 - $up_inv_prefix); | ||||
| 5160 | 8 | 74 | $up = new( | ||||
| 5161 | 'Subnet', | ||||||
| 5162 | name => $name, | ||||||
| 5163 | network => $network, | ||||||
| 5164 | ip => $ip, | ||||||
| 5165 | mask => $mask | ||||||
| 5166 | ); | ||||||
| 5167 | 8 | 18 | if (my $private = $subnet->{private}) { | ||||
| 5168 | 0 | 0 | $up->{private} = $private if $private; | ||||
| 5169 | } | ||||||
| 5170 | 8 | 16 | $inv_prefix_aref[$up_inv_prefix]->{$ip} = $up; | ||||
| 5171 | } | ||||||
| 5172 | 8 | 9 | $subnet->{up} = $up; | ||||
| 5173 | 8 | 8 | $neighbor->{up} = $up; | ||||
| 5174 | 8 8 | 9 11 | push @{ $network->{subnets} }, $up; | ||||
| 5175 | |||||||
| 5176 | # Don't search for enclosing subnet below. | ||||||
| 5177 | 8 | 15 | next; | ||||
| 5178 | } | ||||||
| 5179 | } | ||||||
| 5180 | |||||||
| 5181 | # For neighbors, {up} has been set already. | ||||||
| 5182 | 188 | 299 | next if $subnet->{up}; | ||||
| 5183 | |||||||
| 5184 | # Search for enclosing subnet. | ||||||
| 5185 | 183 | 370 | for (my $j = $i + 1 ; $j < @inv_prefix_aref ; $j++) { | ||||
| 5186 | 52 | 63 | my $mask = prefix2mask(32 - $j); | ||||
| 5187 | 52 | 56 | $ip = $ip & $mask; # Perl bug #108480 | ||||
| 5188 | 52 | 129 | if (my $up = $inv_prefix_aref[$j]->{$ip}) { | ||||
| 5189 | 7 | 9 | $subnet->{up} = $up; | ||||
| 5190 | 7 | 6 | last; | ||||
| 5191 | } | ||||||
| 5192 | } | ||||||
| 5193 | |||||||
| 5194 | # Use network, if no enclosing subnet found. | ||||||
| 5195 | 183 | 862 | $subnet->{up} ||= $network; | ||||
| 5196 | } | ||||||
| 5197 | } | ||||||
| 5198 | } | ||||||
| 5199 | |||||||
| 5200 | # Attribute {up} has been set for all subnets now. | ||||||
| 5201 | # Do the same for interfaces. | ||||||
| 5202 | 1147 1147 | 892 1497 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 5203 | 1497 | 2759 | $interface->{up} = $network; | ||||
| 5204 | } | ||||||
| 5205 | } | ||||||
| 5206 | 321 | 351 | return; | ||||
| 5207 | } | ||||||
| 5208 | |||||||
| 5209 | # Find adjacent subnets and substitute them by their enclosing subnet. | ||||||
| 5210 | sub combine_subnets { | ||||||
| 5211 | 596 | 0 | 526 | my ($subnets) = @_; | |||
| 5212 | 596 102 | 729 245 | my %hash = map { $_ => $_ } @$subnets; | ||||
| 5213 | 596 | 447 | my @extra; | ||||
| 5214 | 596 | 459 | while(1) { | ||||
| 5215 | 600 | 667 | for my $subnet (@$subnets) { | ||||
| 5216 | 148 | 98 | my $neighbor; | ||||
| 5217 | 148 | 390 | if ($neighbor = $subnet->{neighbor} and $hash{$neighbor}) { | ||||
| 5218 | 5 | 3 | my $up = $subnet->{up}; | ||||
| 5219 | 5 | 10 | unless ($hash{$up}) { | ||||
| 5220 | 5 | 6 | $hash{$up} = $up; | ||||
| 5221 | 5 | 6 | push @extra, $up; | ||||
| 5222 | } | ||||||
| 5223 | 5 | 6 | delete $hash{$subnet}; | ||||
| 5224 | 5 | 8 | delete $hash{$neighbor}; | ||||
| 5225 | } | ||||||
| 5226 | } | ||||||
| 5227 | 600 | 749 | if (@extra) { | ||||
| 5228 | |||||||
| 5229 | # Try again to combine subnets with extra subnets. | ||||||
| 5230 | # This version isn't optimized. | ||||||
| 5231 | 4 | 7 | push @$subnets, @extra; | ||||
| 5232 | 4 | 4 | @extra = (); | ||||
| 5233 | } | ||||||
| 5234 | else { | ||||||
| 5235 | 596 | 542 | last; | ||||
| 5236 | } | ||||||
| 5237 | } | ||||||
| 5238 | |||||||
| 5239 | # Sort networks by size of mask, | ||||||
| 5240 | # i.e. large subnets coming first and | ||||||
| 5241 | # for equal mask by IP address. | ||||||
| 5242 | # We need this to make the output deterministic. | ||||||
| 5243 | 596 23 | 1277 133 | return [ sort { $a->{mask} <=> $b->{mask} || $a->{ip} <=> $b->{ip} } | ||||
| 5244 | values %hash ]; | ||||||
| 5245 | } | ||||||
| 5246 | |||||||
| 5247 | #################################################################### | ||||||
| 5248 | # Expand rules | ||||||
| 5249 | # | ||||||
| 5250 | # Simplify rules to expanded rules where each rule has exactly one | ||||||
| 5251 | # src, dst and prt | ||||||
| 5252 | #################################################################### | ||||||
| 5253 | |||||||
| 5254 | my %name2object = ( | ||||||
| 5255 | host => \%hosts, | ||||||
| 5256 | network => \%networks, | ||||||
| 5257 | interface => \%interfaces, | ||||||
| 5258 | any => \%aggregates, | ||||||
| 5259 | group => \%groups, | ||||||
| 5260 | area => \%areas, | ||||||
| 5261 | ); | ||||||
| 5262 | |||||||
| 5263 | sub get_intf { | ||||||
| 5264 | 71 | 0 | 65 | my ($router) = @_; | |||
| 5265 | 71 | 165 | if (my $orig_router = $router->{orig_router}) { | ||||
| 5266 | 0 0 | 0 0 | return @{ $orig_router->{orig_interfaces} }; | ||||
| 5267 | } | ||||||
| 5268 | elsif (my $orig_interfaces = $router->{orig_interfaces}) { | ||||||
| 5269 | 10 | 21 | return @$orig_interfaces; | ||||
| 5270 | } | ||||||
| 5271 | else { | ||||||
| 5272 | 61 61 | 43 144 | return @{ $router->{interfaces} }; | ||||
| 5273 | } | ||||||
| 5274 | } | ||||||
| 5275 | |||||||
| 5276 | my %auto_interfaces; | ||||||
| 5277 | |||||||
| 5278 | sub get_auto_intf { | ||||||
| 5279 | 49 | 0 | 41 | my ($object, $managed) = @_; | |||
| 5280 | 49 | 126 | $managed ||= 0; | ||||
| 5281 | 49 | 85 | my $result = $auto_interfaces{$object}->{$managed}; | ||||
| 5282 | 49 | 76 | if (not $result) { | ||||
| 5283 | 23 | 16 | my $name; | ||||
| 5284 | 23 | 27 | if (is_router $object) { | ||||
| 5285 | 17 | 70 | ($name = $object->{name}) =~ s/^router://; | ||||
| 5286 | } | ||||||
| 5287 | else { | ||||||
| 5288 | 6 | 13 | $name = "[$object->{name}]"; | ||||
| 5289 | } | ||||||
| 5290 | 23 | 55 | $name = "interface:$name.[auto]"; | ||||
| 5291 | 23 | 35 | $result = new( | ||||
| 5292 | 'Autointerface', | ||||||
| 5293 | name => $name, | ||||||
| 5294 | object => $object, | ||||||
| 5295 | managed => $managed | ||||||
| 5296 | ); | ||||||
| 5297 | 23 | 36 | $result->{disabled} = 1 if $object->{disabled}; | ||||
| 5298 | 23 | 46 | $auto_interfaces{$object}->{$managed} = $result; | ||||
| 5299 | |||||||
| 5300 | # debug($result->{name}); | ||||||
| 5301 | } | ||||||
| 5302 | 49 | 109 | return $result; | ||||
| 5303 | } | ||||||
| 5304 | |||||||
| 5305 | # Check intersection of interface and auto-interface. | ||||||
| 5306 | # Prevent expressions like "interface:r.x &! interface:r.[auto]", | ||||||
| 5307 | # because we don't know the exact value of the auto-interface. | ||||||
| 5308 | # The auto-interface could be "r.x" but not for sure. | ||||||
| 5309 | # $info is hash with attributes | ||||||
| 5310 | # - i => { $router => $interface, ... } | ||||||
| 5311 | # - r => { $router => $autointerface, ... } | ||||||
| 5312 | # - n => { $router => { $network => autointerface, ... }, ... } | ||||||
| 5313 | # | ||||||
| 5314 | # interface:router.network conflicts with interface:router.[auto] | ||||||
| 5315 | # interface:router.network conflicts with interface:[network].[auto] | ||||||
| 5316 | # interface:router:[auto] conflicts with interface:[network].[auto] | ||||||
| 5317 | # if router is connected to network. | ||||||
| 5318 | sub check_auto_intf { | ||||||
| 5319 | 28 | 0 | 33 | my ($info, $elements, $context) = @_; | |||
| 5320 | 28 | 27 | my $add_info = {}; | ||||
| 5321 | |||||||
| 5322 | # Check current elements with interfaces of previous elements. | ||||||
| 5323 | 28 | 32 | for my $obj (@$elements) { | ||||
| 5324 | 37 | 37 | my $type = ref $obj; | ||||
| 5325 | 37 | 23 | my $other; | ||||
| 5326 | 37 | 70 | if ($type eq 'Interface') { | ||||
| 5327 | 10 | 9 | my $router = $obj->{router}; | ||||
| 5328 | 10 | 10 | my $network = $obj->{network}; | ||||
| 5329 | 10 | 42 | $other = $info->{r}->{$router} || $info->{n}->{$router}->{$network}; | ||||
| 5330 | 10 | 21 | $add_info->{i}->{$router} = $obj; | ||||
| 5331 | } | ||||||
| 5332 | elsif ($type eq 'Autointerface') { | ||||||
| 5333 | 14 | 13 | my $auto = $obj->{object}; | ||||
| 5334 | 14 | 15 | if (is_router($auto)) { | ||||
| 5335 | 6 | 5 | my $router = $auto; | ||||
| 5336 | 6 | 10 | $other = $info->{i}->{$router}; | ||||
| 5337 | 6 | 9 | if (!$other) { | ||||
| 5338 | 6 | 9 | my $href = $info->{n}->{$router}; | ||||
| 5339 | 6 | 13 | $other = (values %$href)[0]; | ||||
| 5340 | } | ||||||
| 5341 | 6 | 12 | $add_info->{r}->{$router} = $obj; | ||||
| 5342 | } | ||||||
| 5343 | else { | ||||||
| 5344 | 8 | 8 | my $network = $auto; | ||||
| 5345 | 8 8 | 7 10 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 5346 | 8 | 7 | my $router = $interface->{router}; | ||||
| 5347 | 8 | 11 | $other = $info->{r}->{$router}; | ||||
| 5348 | 8 | 32 | if (!$other && ($other = $info->{i}->{$router})) { | ||||
| 5349 | 0 | 0 | if (!$other->{network} eq $network) { | ||||
| 5350 | 0 | 0 | $other = undef; | ||||
| 5351 | } | ||||||
| 5352 | } | ||||||
| 5353 | 8 | 26 | $add_info->{n}->{$router}->{$network} = $obj; | ||||
| 5354 | } | ||||||
| 5355 | } | ||||||
| 5356 | } | ||||||
| 5357 | 37 | 78 | if ($other) { | ||||
| 5358 | 6 | 22 | err_msg("Must not use $other->{name} and $obj->{name} together\n", | ||||
| 5359 | " in intersection of $context"); | ||||||
| 5360 | } | ||||||
| 5361 | } | ||||||
| 5362 | |||||||
| 5363 | # Extend info with values of current elements. | ||||||
| 5364 | 28 | 51 | for my $key (keys %$add_info) { | ||||
| 5365 | 24 | 21 | my $href = $add_info->{$key}; | ||||
| 5366 | 24 | 37 | for my $rkey (%$href) { | ||||
| 5367 | 48 | 46 | my $val = $href->{$rkey}; | ||||
| 5368 | 48 | 61 | if (ref $val) { | ||||
| 5369 | 24 24 | 49 96 | @{$info->{$key}->{$rkey}}{keys %$val} = values %$val; | ||||
| 5370 | } | ||||||
| 5371 | else { | ||||||
| 5372 | 24 | 66 | $info->{$key}->{$rkey} = $val; | ||||
| 5373 | } | ||||||
| 5374 | } | ||||||
| 5375 | } | ||||||
| 5376 | 28 | 55 | return; | ||||
| 5377 | } | ||||||
| 5378 | |||||||
| 5379 | # Get a reference to an array of network object descriptions and | ||||||
| 5380 | # return a reference to an array of network objects. | ||||||
| 5381 | sub expand_group1; | ||||||
| 5382 | |||||||
| 5383 | sub expand_group1 { | ||||||
| 5384 | 1763 | 0 | 1668 | my ($aref, $context, $clean_autogrp) = @_; | |||
| 5385 | 1763 | 1316 | my @objects; | ||||
| 5386 | 1763 | 1752 | for my $parts (@$aref) { | ||||
| 5387 | |||||||
| 5388 | 2017 | 2328 | my ($type, $name, $ext) = @$parts; | ||||
| 5389 | 2017 | 7158 | if ($type eq '&') { | ||||
| 5390 | 14 | 13 | my @non_compl; | ||||
| 5391 | my @compl; | ||||||
| 5392 | 0 | 0 | my %autointf_info; | ||||
| 5393 | 14 | 17 | for my $element (@$name) { | ||||
| 5394 | 28 | 40 | my $element1 = $element->[0] eq '!' ? $element->[1] : $element; | ||||
| 5395 | 37 | 40 | my @elements = | ||||
| 5396 | 37 28 | 61 95 | map { $_->{is_used} = 1; $_; } @{ | ||||
| 5397 | 28 | 26 | expand_group1( | ||||
| 5398 | [$element1], "intersection of $context", | ||||||
| 5399 | $clean_autogrp | ||||||
| 5400 | ) | ||||||
| 5401 | }; | ||||||
| 5402 | 28 | 54 | check_auto_intf(\%autointf_info, \@elements, $context); | ||||
| 5403 | 28 | 50 | if ($element->[0] eq '!') { | ||||
| 5404 | 13 | 22 | push @compl, @elements; | ||||
| 5405 | } | ||||||
| 5406 | else { | ||||||
| 5407 | 15 | 23 | push @non_compl, \@elements; | ||||
| 5408 | } | ||||||
| 5409 | } | ||||||
| 5410 | 14 | 27 | @non_compl >= 1 | ||||
| 5411 | or err_msg "Intersection needs at least one element", | ||||||
| 5412 | " which is not complement in $context"; | ||||||
| 5413 | 14 | 14 | my $result; | ||||
| 5414 | 14 | 16 | my $first_set = shift @non_compl; | ||||
| 5415 | 14 | 17 | for my $element (@$first_set) { | ||||
| 5416 | 22 | 45 | $result->{$element} = $element; | ||||
| 5417 | } | ||||||
| 5418 | 14 | 17 | for my $set (@non_compl) { | ||||
| 5419 | 1 | 1 | my $intersection; | ||||
| 5420 | 1 | 1 | for my $element (@$set) { | ||||
| 5421 | 2 | 5 | if ($result->{$element}) { | ||||
| 5422 | 1 | 2 | $intersection->{$element} = $element; | ||||
| 5423 | } | ||||||
| 5424 | } | ||||||
| 5425 | 1 | 2 | $result = $intersection; | ||||
| 5426 | } | ||||||
| 5427 | 14 | 16 | for my $element (@compl) { | ||||
| 5428 | 13 | 23 | next if $element->{disabled}; | ||||
| 5429 | 13 | 48 | delete $result->{$element} | ||||
| 5430 | or warn_msg("Useless delete of $element->{name} in $context"); | ||||||
| 5431 | } | ||||||
| 5432 | |||||||
| 5433 | # Put result into same order as the elements of first non | ||||||
| 5434 | # complemented set. This set contains all elements of resulting set, | ||||||
| 5435 | # because we are doing intersection here. | ||||||
| 5436 | 14 22 | 17 99 | push @objects, grep { $result->{$_} } @$first_set; | ||||
| 5437 | } | ||||||
| 5438 | elsif ($type eq '!') { | ||||||
| 5439 | 0 | 0 | err_msg("Complement (!) is only supported as part of intersection", | ||||
| 5440 | " in $context"); | ||||||
| 5441 | } | ||||||
| 5442 | elsif ($type eq 'user') { | ||||||
| 5443 | |||||||
| 5444 | # Either a single object or an array of objects. | ||||||
| 5445 | 308 | 308 | my $elements = $name->{elements}; | ||||
| 5446 | 308 | 836 | push @objects, ref($elements) eq 'ARRAY' ? @$elements : $elements; | ||||
| 5447 | } | ||||||
| 5448 | elsif ($type eq 'interface') { | ||||||
| 5449 | 266 | 212 | my @check; | ||||
| 5450 | 266 | 824 | if (ref $name) { | ||||
| 5451 | 18 | 29 | ref $ext | ||||
| 5452 | or err_msg("Must not use interface:[..].$ext in $context"); | ||||||
| 5453 | 18 | 20 | my ($selector, $managed) = @$ext; | ||||
| 5454 | 18 | 101 | my $sub_objects = expand_group1 $name, | ||||
| 5455 | "interface:[..].[$selector] of $context"; | ||||||
| 5456 | 18 | 27 | for my $object (@$sub_objects) { | ||||
| 5457 | 18 | 29 | next if $object->{disabled}; | ||||
| 5458 | 18 | 19 | $object->{is_used} = 1; | ||||
| 5459 | 18 | 19 | my $type = ref $object; | ||||
| 5460 | 18 | 31 | if ($type eq 'Network') { | ||||
| 5461 | 12 | 13 | if ($selector eq 'all') { | ||||
| 5462 | 0 | 0 | if ($object->{is_aggregate}) { | ||||
| 5463 | |||||||
| 5464 | # We can't simply take | ||||||
| 5465 | # aggregate -> networks -> interfaces, | ||||||
| 5466 | # because subnets may be missing. | ||||||
| 5467 | 0 | 0 | $object->{mask} == 0 | ||||
| 5468 | or err_msg "Must not use", | ||||||
| 5469 | " interface:[..].[all]\n", | ||||||
| 5470 | " with $object->{name} having ip/mask\n", | ||||||
| 5471 | " in $context"; | ||||||
| 5472 | 0 0 | 0 0 | push @check, @{ $object->{zone}->{interfaces} }; | ||||
| 5473 | } | ||||||
| 5474 | elsif ($managed) { | ||||||
| 5475 | 0 | 0 | push @check, | ||||
| 5476 | 0 | 0 | grep({ $_->{router}->{managed} || | ||||
| 5477 | $_->{router}->{routing_only} } | ||||||
| 5478 | 0 | 0 | @{ $object->{interfaces} }); | ||||
| 5479 | } | ||||||
| 5480 | else { | ||||||
| 5481 | 0 0 | 0 0 | push @check, @{ $object->{interfaces} }; | ||||
| 5482 | } | ||||||
| 5483 | } | ||||||
| 5484 | else { | ||||||
| 5485 | 12 | 14 | if ($object->{is_aggregate}) { | ||||
| 5486 | 0 | 0 | err_msg "Must not use", | ||||
| 5487 | " interface:[any:..].[auto]", | ||||||
| 5488 | " in $context"; | ||||||
| 5489 | } | ||||||
| 5490 | else { | ||||||
| 5491 | 12 | 15 | push @objects, get_auto_intf $object, $managed; | ||||
| 5492 | } | ||||||
| 5493 | } | ||||||
| 5494 | } | ||||||
| 5495 | elsif ($type eq 'Interface') { | ||||||
| 5496 | 0 | 0 | my $router = $object->{router}; | ||||
| 5497 | 0 | 0 | if ($managed && !($router->{managed} || | ||||
| 5498 | $router->{routing_only})) | ||||||
| 5499 | { | ||||||
| 5500 | |||||||
| 5501 | # Do nothing. | ||||||
| 5502 | } | ||||||
| 5503 | elsif ($selector eq 'all') { | ||||||
| 5504 | 0 | 0 | push @check, get_intf($router); | ||||
| 5505 | } | ||||||
| 5506 | else { | ||||||
| 5507 | 0 | 0 | push @objects, get_auto_intf $router; | ||||
| 5508 | } | ||||||
| 5509 | } | ||||||
| 5510 | elsif ($type eq 'Area') { | ||||||
| 5511 | 6 | 5 | my @routers; | ||||
| 5512 | |||||||
| 5513 | # Prevent duplicates and border routers. | ||||||
| 5514 | my %seen; | ||||||
| 5515 | |||||||
| 5516 | # Don't add routers at border of this area. | ||||||
| 5517 | 6 6 | 5 10 | for my $interface (@{ $object->{border} }) { | ||||
| 5518 | 4 | 12 | $seen{ $interface->{router} } = 1; | ||||
| 5519 | } | ||||||
| 5520 | |||||||
| 5521 | # Add routers at border of security zones inside | ||||||
| 5522 | # current area. | ||||||
| 5523 | 6 16 | 5 20 | for my $router ( | ||||
| 5524 | 12 | 14 | map { $_->{router} } | ||||
| 5525 | 6 | 10 | map { get_intf($_) } | ||||
| 5526 | @{ $object->{zones} } | ||||||
| 5527 | ) | ||||||
| 5528 | { | ||||||
| 5529 | 16 | 36 | if (not $seen{$router}) { | ||||
| 5530 | 6 | 4 | push @routers, $router; | ||||
| 5531 | 6 | 11 | $seen{$router} = 1; | ||||
| 5532 | } | ||||||
| 5533 | } | ||||||
| 5534 | 6 | 9 | if ($managed) { | ||||
| 5535 | |||||||
| 5536 | # Remove semi managed routers. | ||||||
| 5537 | 4 6 | 5 15 | @routers = grep({ $_->{managed} || | ||||
| 5538 | $_->{routing_only} } | ||||||
| 5539 | @routers); | ||||||
| 5540 | } | ||||||
| 5541 | else { | ||||||
| 5542 | 2 | 3 | push @routers, map { | ||||
| 5543 | 2 | 2 | my $r = $_->{unmanaged_routers}; | ||||
| 5544 | 2 | 6 | $r ? @$r : () | ||||
| 5545 | 2 | 3 | } @{ $object->{zones} }; | ||||
| 5546 | } | ||||||
| 5547 | 6 | 19 | if ($selector eq 'all') { | ||||
| 5548 | 2 10 | 2 10 | push @check, map { get_intf($_) } @routers; | ||||
| 5549 | } | ||||||
| 5550 | else { | ||||||
| 5551 | 4 6 | 4 9 | push @objects, map { get_auto_intf($_) } @routers; | ||||
| 5552 | } | ||||||
| 5553 | } | ||||||
| 5554 | elsif ($type eq 'Autointerface') { | ||||||
| 5555 | 0 | 0 | my $obj = $object->{object}; | ||||
| 5556 | 0 | 0 | if (is_router $obj) { | ||||
| 5557 | 0 | 0 | if ($managed && !($obj->{managed} || | ||||
| 5558 | $obj->{routing_only})) | ||||||
| 5559 | { | ||||||
| 5560 | |||||||
| 5561 | # This router has no managed interfaces. | ||||||
| 5562 | } | ||||||
| 5563 | elsif ($selector eq 'all') { | ||||||
| 5564 | 0 | 0 | push @check, get_intf($obj); | ||||
| 5565 | } | ||||||
| 5566 | else { | ||||||
| 5567 | 0 | 0 | push @objects, get_auto_intf $obj; | ||||
| 5568 | } | ||||||
| 5569 | } | ||||||
| 5570 | else { | ||||||
| 5571 | 0 | 0 | err_msg "Can't use $object->{name} inside", | ||||
| 5572 | " interface:[..].[$selector] of $context"; | ||||||
| 5573 | } | ||||||
| 5574 | } | ||||||
| 5575 | else { | ||||||
| 5576 | 0 | 0 | err_msg | ||||
| 5577 | "Unexpected type '$type' in interface:[..] of $context"; | ||||||
| 5578 | } | ||||||
| 5579 | } | ||||||
| 5580 | } | ||||||
| 5581 | |||||||
| 5582 | # interface:name.[xxx] | ||||||
| 5583 | elsif (ref $ext) { | ||||||
| 5584 | 43 | 45 | my ($selector, $managed) = @$ext; | ||||
| 5585 | 43 | 80 | if (my $router = $routers{$name}) { | ||||
| 5586 | |||||||
| 5587 | # Syntactically impossible. | ||||||
| 5588 | 43 | 59 | $managed and internal_err(); | ||||
| 5589 | 43 | 54 | if ($selector eq 'all') { | ||||
| 5590 | 12 | 24 | push @check, get_intf($router); | ||||
| 5591 | } | ||||||
| 5592 | else { | ||||||
| 5593 | 31 | 45 | push @objects, get_auto_intf $router; | ||||
| 5594 | } | ||||||
| 5595 | } | ||||||
| 5596 | else { | ||||||
| 5597 | 0 | 0 | err_msg("Can't resolve $type:$name.[$selector] in $context"); | ||||
| 5598 | } | ||||||
| 5599 | } | ||||||
| 5600 | |||||||
| 5601 | # interface:name.name | ||||||
| 5602 | elsif (my $interface = $interfaces{"$name.$ext"}) { | ||||||
| 5603 | 205 | 237 | push @objects, $interface; | ||||
| 5604 | } | ||||||
| 5605 | else { | ||||||
| 5606 | 0 | 0 | err_msg("Can't resolve $type:$name.$ext in $context"); | ||||
| 5607 | } | ||||||
| 5608 | |||||||
| 5609 | # Silently remove unnumbered, bridged and tunnel interfaces | ||||||
| 5610 | # from automatic groups. | ||||||
| 5611 | 68 | 112 | push @objects, | ||||
| 5612 | 64 | 120 | grep { $_->{ip} ne 'tunnel' } | ||||
| 5613 | $clean_autogrp | ||||||
| 5614 | 266 | 617 | ? grep { $_->{ip} !~ /^(?:unnumbered|bridged)$/ } @check | ||||
| 5615 | : @check; | ||||||
| 5616 | } | ||||||
| 5617 | elsif (ref $name) { | ||||||
| 5618 | 198 | 209 | my $sub_objects = [ | ||||
| 5619 | 198 198 | 333 374 | map { $_->{is_used} = 1; $_; } | ||||
| 5620 | 183 | 804 | grep { not($_->{disabled}) } | ||||
| 5621 | 183 | 168 | @{ expand_group1($name, "$type:[..] of $context") } | ||||
| 5622 | ]; | ||||||
| 5623 | my $get_aggregates = sub { | ||||||
| 5624 | 165 | 178 | my ($object, $ip, $mask) = @_; | ||||
| 5625 | 165 | 114 | my @objects; | ||||
| 5626 | 165 | 178 | my $type = ref $object; | ||||
| 5627 | 165 | 562 | if ($type eq 'Area') { | ||||
| 5628 | 39 20 | 51 34 | push @objects, unique(map({ get_any($_, $ip, $mask) } | ||||
| 5629 | 20 | 15 | @{ $object->{zones} })); | ||||
| 5630 | } | ||||||
| 5631 | elsif ($type eq 'Network' && $object->{is_aggregate}) { | ||||||
| 5632 | 2 | 4 | push @objects, get_any($object->{zone}, $ip, $mask); | ||||
| 5633 | } | ||||||
| 5634 | else { | ||||||
| 5635 | 143 | 347 | return; | ||||
| 5636 | } | ||||||
| 5637 | 22 | 55 | return \@objects; | ||||
| 5638 | 183 | 626 | }; | ||||
| 5639 | my $get_networks = sub { | ||||||
| 5640 | 186 | 185 | my ($object) = @_; | ||||
| 5641 | 186 | 133 | my @objects; | ||||
| 5642 | 186 | 185 | my $type = ref $object; | ||||
| 5643 | 186 | 647 | if ($type eq 'Host' or $type eq 'Interface') { | ||||
| 5644 | 18 | 29 | push @objects, $object->{network}; | ||||
| 5645 | } | ||||||
| 5646 | elsif ($type eq 'Network') { | ||||||
| 5647 | 158 | 206 | if (!$object->{is_aggregate}) { | ||||
| 5648 | 143 | 156 | push @objects, $object; | ||||
| 5649 | } | ||||||
| 5650 | |||||||
| 5651 | # Take aggregate directly. Don't use next "elsif" | ||||||
| 5652 | # clause below, where it would be changed to non | ||||||
| 5653 | # matching aggregate with IP 0/0. | ||||||
| 5654 | else { | ||||||
| 5655 | 15 15 | 13 23 | push @objects, @{ $object->{networks} }; | ||||
| 5656 | } | ||||||
| 5657 | } | ||||||
| 5658 | elsif (my $aggregates = $get_aggregates->($object, 0, 0)) { | ||||||
| 5659 | 19 | 31 | push(@objects, | ||||
| 5660 | |||||||
| 5661 | # Check type, because $get_aggregates | ||||||
| 5662 | # eventually returns non aggregate network if | ||||||
| 5663 | # one matches 0/0. | ||||||
| 5664 | 10 21 | 16 33 | map({ $_->{is_aggregate} ? @{ $_->{networks} } : $_ } | ||||
| 5665 | @$aggregates)); | ||||||
| 5666 | } | ||||||
| 5667 | else { | ||||||
| 5668 | 0 | 0 | return; | ||||
| 5669 | } | ||||||
| 5670 | 186 | 356 | return \@objects; | ||||
| 5671 | 183 | 429 | }; | ||||
| 5672 | 183 | 434 | if ($type eq 'host') { | ||||
| 5673 | 12 | 13 | my $managed = $ext; | ||||
| 5674 | 12 | 11 | my @hosts; | ||||
| 5675 | 12 | 17 | for my $object (@$sub_objects) { | ||||
| 5676 | 12 | 13 | my $type = ref $object; | ||||
| 5677 | 12 | 30 | if ($type eq 'Host') { | ||||
| 5678 | 0 | 0 | push @hosts, $object; | ||||
| 5679 | } | ||||||
| 5680 | elsif ($type eq 'Interface') { | ||||||
| 5681 | 0 | 0 | if ($object->{is_managed_host}) { | ||||
| 5682 | 0 | 0 | push @hosts, $object; | ||||
| 5683 | } | ||||||
| 5684 | else { | ||||||
| 5685 | 0 | 0 | err_msg | ||||
| 5686 | "Unexpected interface in host:[..] of $context"; | ||||||
| 5687 | } | ||||||
| 5688 | } | ||||||
| 5689 | elsif (my $networks = $get_networks->($object)) { | ||||||
| 5690 | 12 | 15 | for my $network (@$networks) { | ||||
| 5691 | 12 12 | 9 21 | push @hosts, @{ $network->{hosts} }; | ||||
| 5692 | 12 | 27 | if (my $managed_hosts = $network->{managed_hosts}) { | ||||
| 5693 | 8 | 21 | push @hosts, @$managed_hosts; | ||||
| 5694 | } | ||||||
| 5695 | } | ||||||
| 5696 | } | ||||||
| 5697 | else { | ||||||
| 5698 | 0 | 0 | err_msg | ||||
| 5699 | "Unexpected type '$type' in host:[..] of $context"; | ||||||
| 5700 | } | ||||||
| 5701 | } | ||||||
| 5702 | 12 | 20 | if ($managed) { | ||||
| 5703 | 4 8 | 4 12 | @hosts = grep { $_->{is_managed_host} } @hosts; | ||||
| 5704 | } | ||||||
| 5705 | 12 | 99 | push @objects, @hosts; | ||||
| 5706 | } | ||||||
| 5707 | elsif ($type eq 'network') { | ||||||
| 5708 | 23 | 40 | $ext and internal_err; | ||||
| 5709 | 23 | 20 | my @list; | ||||
| 5710 | 23 | 29 | for my $object (@$sub_objects) { | ||||
| 5711 | 31 | 39 | if (my $networks = $get_networks->($object)) { | ||||
| 5712 | |||||||
| 5713 | # Silently remove from automatic groups: | ||||||
| 5714 | # - crosslink network | ||||||
| 5715 | # - loopback network of managed device | ||||||
| 5716 | # Change loopback network of unmanaged device | ||||||
| 5717 | # to loopback interface. | ||||||
| 5718 | push @list, $clean_autogrp | ||||||
| 5719 | ? map { | ||||||
| 5720 | 47 47 | 61 76 | if ($_->{loopback}) | ||||
| 5721 | { | ||||||
| 5722 | 2 | 2 | my $interfaces = $_->{interfaces}; | ||||
| 5723 | 2 | 3 | my $intf = $interfaces->[0]; | ||||
| 5724 | 2 | 3 | if ($intf->{router}->{managed}) { | ||||
| 5725 | 2 | 4 | (); | ||||
| 5726 | } | ||||||
| 5727 | else { | ||||||
| 5728 | 0 | 0 | if (@$interfaces > 1) { | ||||
| 5729 | 0 | 0 | warn_msg( | ||||
| 5730 | "Must not use $_->{name},", | ||||||
| 5731 | " use interfaces instead" | ||||||
| 5732 | ); | ||||||
| 5733 | } | ||||||
| 5734 | 0 | 0 | $intf; | ||||
| 5735 | } | ||||||
| 5736 | } | ||||||
| 5737 | else { | ||||||
| 5738 | 45 | 89 | $_; | ||||
| 5739 | } | ||||||
| 5740 | } | ||||||
| 5741 | 31 | 55 | grep { not($_->{crosslink}) } @$networks | ||||
| 5742 | : @$networks; | ||||||
| 5743 | } | ||||||
| 5744 | else { | ||||||
| 5745 | 0 | 0 | my $type = ref $object; | ||||
| 5746 | 0 | 0 | err_msg("Unexpected type '$type' in network:[..] of", | ||||
| 5747 | " $context"); | ||||||
| 5748 | } | ||||||
| 5749 | } | ||||||
| 5750 | |||||||
| 5751 | # Ignore duplicate networks resulting from different | ||||||
| 5752 | # interfaces connected to the same network. | ||||||
| 5753 | 23 | 36 | push @objects, unique(@list); | ||||
| 5754 | } | ||||||
| 5755 | elsif ($type eq 'any') { | ||||||
| 5756 | 148 | 239 | my ($ip, $mask) = $ext ? @$ext : (0, 0); | ||||
| 5757 | 148 | 122 | my @list; | ||||
| 5758 | 148 | 164 | for my $object (@$sub_objects) { | ||||
| 5759 | 155 | 218 | if (my $aggregates = | ||||
| 5760 | $get_aggregates->($object, $ip, $mask)) | ||||||
| 5761 | { | ||||||
| 5762 | 12 | 26 | push @list, @$aggregates; | ||||
| 5763 | } | ||||||
| 5764 | elsif (my $networks = $get_networks->($object)) { | ||||||
| 5765 | 143 143 | 168 219 | push @list, map({ get_any($_->{zone}, $ip, $mask) } | ||||
| 5766 | @$networks); | ||||||
| 5767 | } | ||||||
| 5768 | else { | ||||||
| 5769 | 0 | 0 | my $type = ref $object; | ||||
| 5770 | 0 | 0 | err_msg | ||||
| 5771 | "Unexpected type '$type' in any:[..]", | ||||||
| 5772 | " of $context"; | ||||||
| 5773 | } | ||||||
| 5774 | } | ||||||
| 5775 | |||||||
| 5776 | # Ignore duplicate aggregates resulting from different | ||||||
| 5777 | # interfaces connected to the same aggregate. | ||||||
| 5778 | 148 | 207 | push @objects, unique(@list); | ||||
| 5779 | } | ||||||
| 5780 | else { | ||||||
| 5781 | 0 | 0 | err_msg("Unexpected $type:[..] in $context"); | ||||
| 5782 | } | ||||||
| 5783 | } | ||||||
| 5784 | |||||||
| 5785 | # An object named simply 'type:name'. | ||||||
| 5786 | elsif (my $object = $name2object{$type}->{$name}) { | ||||||
| 5787 | |||||||
| 5788 | 1246 | 1730 | $ext | ||||
| 5789 | and err_msg("Unexpected '.$ext' after $type:$name in $context"); | ||||||
| 5790 | |||||||
| 5791 | # Split a group into its members. | ||||||
| 5792 | # There may be two different versions depending of $clean_autogrp. | ||||||
| 5793 | 1246 | 1541 | if (is_group $object) { | ||||
| 5794 | |||||||
| 5795 | # Two different expanded values, depending on $clean_autogrp. | ||||||
| 5796 | 13 | 24 | my $ext = $clean_autogrp ? 'clean' : 'noclean'; | ||||
| 5797 | 13 | 24 | my $attr_name = "expanded_$ext"; | ||||
| 5798 | |||||||
| 5799 | 13 | 16 | my $elements = $object->{$attr_name}; | ||||
| 5800 | |||||||
| 5801 | # Check for recursive definition. | ||||||
| 5802 | 13 | 38 | if ($object->{recursive}) { | ||||
| 5803 | 0 | 0 | err_msg("Found recursion in definition of $context"); | ||||
| 5804 | 0 | 0 | $object->{$attr_name} = $elements = []; | ||||
| 5805 | 0 | 0 | delete $object->{recursive}; | ||||
| 5806 | } | ||||||
| 5807 | |||||||
| 5808 | # Group has not been converted from names to references. | ||||||
| 5809 | elsif (not $elements) { | ||||||
| 5810 | |||||||
| 5811 | # Add marker for detection of recursive group definition. | ||||||
| 5812 | 9 | 13 | $object->{recursive} = 1; | ||||
| 5813 | |||||||
| 5814 | # Mark group as used. | ||||||
| 5815 | 9 | 10 | $object->{is_used} = 1; | ||||
| 5816 | |||||||
| 5817 | 9 | 140 | $elements = | ||||
| 5818 | expand_group1($object->{elements}, "$type:$name", | ||||||
| 5819 | $clean_autogrp); | ||||||
| 5820 | 9 | 15 | delete $object->{recursive}; | ||||
| 5821 | |||||||
| 5822 | # Private group must not reference private element of other | ||||||
| 5823 | # context. | ||||||
| 5824 | # Public group must not reference private element. | ||||||
| 5825 | 9 | 38 | my $private1 = $object->{private} || 'public'; | ||||
| 5826 | 9 | 11 | for my $element (@$elements) { | ||||
| 5827 | 24 | 49 | if (my $private2 = $element->{private}) { | ||||
| 5828 | 0 | 0 | $private1 eq $private2 | ||||
| 5829 | or err_msg( | ||||||
| 5830 | "$private1 $object->{name} must not", | ||||||
| 5831 | " reference $private2 $element->{name}" | ||||||
| 5832 | ); | ||||||
| 5833 | } | ||||||
| 5834 | } | ||||||
| 5835 | |||||||
| 5836 | # Detect and remove duplicate values in group. | ||||||
| 5837 | 9 | 9 | my %unique; | ||||
| 5838 | my @duplicate; | ||||||
| 5839 | 9 | 15 | for my $obj (@$elements) { | ||||
| 5840 | 24 | 64 | if ($unique{$obj}++) { | ||||
| 5841 | 0 | 0 | push @duplicate, $obj; | ||||
| 5842 | 0 | 0 | $obj = undef; | ||||
| 5843 | } | ||||||
| 5844 | } | ||||||
| 5845 | 9 | 19 | if (@duplicate) { | ||||
| 5846 | 0 0 | 0 0 | $elements = [ grep { defined $_ } @$elements ]; | ||||
| 5847 | 0 | 0 | my $msg = "Duplicate elements in $type:$name:\n " | ||||
| 5848 | 0 | 0 | . join("\n ", map { $_->{name} } @duplicate); | ||||
| 5849 | 0 | 0 | warn_msg($msg); | ||||
| 5850 | } | ||||||
| 5851 | |||||||
| 5852 | # Cache result for further references to the same group | ||||||
| 5853 | # in same $clean_autogrp context. | ||||||
| 5854 | 9 | 19 | $object->{$attr_name} = $elements; | ||||
| 5855 | } | ||||||
| 5856 | 13 | 34 | push @objects, @$elements; | ||||
| 5857 | } | ||||||
| 5858 | |||||||
| 5859 | # Substitute aggregate by aggregate set of zone cluster. | ||||||
| 5860 | elsif ($object->{is_aggregate} && $object->{zone}->{zone_cluster}) { | ||||||
| 5861 | 0 0 | 0 0 | my ($ip, $mask) = @{$object}{qw(ip mask)}; | ||||
| 5862 | 0 | 0 | push(@objects, | ||||
| 5863 | get_cluster_aggregates($object->{zone}, $ip, $mask)); | ||||||
| 5864 | } | ||||||
| 5865 | |||||||
| 5866 | else { | ||||||
| 5867 | 1233 | 2446 | push @objects, $object; | ||||
| 5868 | } | ||||||
| 5869 | |||||||
| 5870 | } | ||||||
| 5871 | else { | ||||||
| 5872 | 0 | 0 | err_msg("Can't resolve $type:$name in $context"); | ||||
| 5873 | } | ||||||
| 5874 | } | ||||||
| 5875 | 1763 | 2561 | return \@objects; | ||||
| 5876 | } | ||||||
| 5877 | |||||||
| 5878 | # Remove and warn about duplicate values in group. | ||||||
| 5879 | sub remove_duplicates { | ||||||
| 5880 | 1530 | 0 | 1381 | my ($aref, $context) = @_; | |||
| 5881 | 1530 | 1133 | my %seen; | ||||
| 5882 | my @duplicate; | ||||||
| 5883 | 1530 | 1552 | for my $obj (@$aref) { | ||||
| 5884 | 2022 | 5553 | if ($seen{$obj}++) { | ||||
| 5885 | 1 | 2 | push @duplicate, $obj; | ||||
| 5886 | 1 | 1 | $obj = undef; | ||||
| 5887 | } | ||||||
| 5888 | } | ||||||
| 5889 | 1530 | 2373 | if (@duplicate) { | ||||
| 5890 | 1 | 4 | my $msg = "Duplicate elements in $context:\n " | ||||
| 5891 | 1 | 3 | . join("\n ", map { $_->{name} } @duplicate); | ||||
| 5892 | 1 | 2 | warn_msg($msg); | ||||
| 5893 | 1 3 | 2 5 | $aref = [ grep { defined $_ } @$aref ]; | ||||
| 5894 | } | ||||||
| 5895 | 1530 | 2175 | return $aref; | ||||
| 5896 | } | ||||||
| 5897 | |||||||
| 5898 | sub expand_group { | ||||||
| 5899 | 1525 | 0 | 1443 | my ($obref, $context) = @_; | |||
| 5900 | 1525 | 1817 | my $aref = expand_group1 $obref, $context, 'clean_autogrp'; | ||||
| 5901 | 1525 | 1913 | $aref = remove_duplicates($aref, $context); | ||||
| 5902 | |||||||
| 5903 | # Ignore disabled objects. | ||||||
| 5904 | 1525 | 1189 | my $changed; | ||||
| 5905 | 1525 | 1494 | for my $object (@$aref) { | ||||
| 5906 | 2011 | 3786 | if ($object->{disabled}) { | ||||
| 5907 | 2 | 2 | $object = undef; | ||||
| 5908 | 2 | 2 | $changed = 1; | ||||
| 5909 | } | ||||||
| 5910 | } | ||||||
| 5911 | 1525 2 | 2105 4 | $aref = [ grep { defined $_ } @$aref ] if $changed; | ||||
| 5912 | 1525 | 2263 | return $aref; | ||||
| 5913 | } | ||||||
| 5914 | |||||||
| 5915 | my %subnet_warning_seen; | ||||||
| 5916 | |||||||
| 5917 | sub expand_group_in_rule { | ||||||
| 5918 | 602 | 0 | 947 | my ($obref, $context, $convert_hosts) = @_; | |||
| 5919 | 602 | 734 | my $aref = expand_group($obref, $context); | ||||
| 5920 | |||||||
| 5921 | # Ignore unusable objects. | ||||||
| 5922 | 602 | 477 | my $changed; | ||||
| 5923 | 602 | 601 | for my $object (@$aref) { | ||||
| 5924 | 766 | 551 | my $ignore; | ||||
| 5925 | 766 | 910 | if (is_network $object) { | ||||
| 5926 | 565 | 1870 | if ($object->{ip} eq 'unnumbered') { | ||||
| 5927 | 0 | 0 | $ignore = "unnumbered $object->{name}"; | ||||
| 5928 | } | ||||||
| 5929 | elsif ($object->{crosslink}) { | ||||||
| 5930 | 0 | 0 | $ignore = "crosslink $object->{name}"; | ||||
| 5931 | } | ||||||
| 5932 | elsif ($object->{is_aggregate}) { | ||||||
| 5933 | 94 | 218 | if ($object->{is_tunnel}) { | ||||
| 5934 | 0 | 0 | $ignore = "$object->{name} with tunnel"; | ||||
| 5935 | } | ||||||
| 5936 | elsif ($object->{has_id_hosts}) { | ||||||
| 5937 | 1 | 2 | $ignore = "$object->{name} with software clients" | ||||
| 5938 | } | ||||||
| 5939 | } | ||||||
| 5940 | } | ||||||
| 5941 | elsif (is_interface $object) { | ||||||
| 5942 | 83 | 227 | if ($object->{ip} =~ /^(short|unnumbered)$/) { | ||||
| 5943 | 0 | 0 | $ignore = "$object->{ip} $object->{name}"; | ||||
| 5944 | } | ||||||
| 5945 | } | ||||||
| 5946 | elsif (is_area $object) { | ||||||
| 5947 | 0 | 0 | $ignore = $object->{name}; | ||||
| 5948 | } | ||||||
| 5949 | 766 | 1520 | if ($ignore) { | ||||
| 5950 | 1 | 6 | $object = undef; | ||||
| 5951 | 1 | 1 | $changed = 1; | ||||
| 5952 | 1 | 4 | warn_msg("Ignoring $ignore in $context"); | ||||
| 5953 | } | ||||||
| 5954 | } | ||||||
| 5955 | 602 1 | 837 2 | $aref = [ grep { defined $_ } @$aref ] if $changed; | ||||
| 5956 | |||||||
| 5957 | 602 | 749 | if ($convert_hosts) { | ||||
| 5958 | 596 | 483 | my @subnets; | ||||
| 5959 | my %subnet2host; | ||||||
| 5960 | 0 | 0 | my @other; | ||||
| 5961 | 596 | 602 | for my $obj (@$aref) { | ||||
| 5962 | |||||||
| 5963 | # debug("group:$obj->{name}"); | ||||||
| 5964 | 752 | 851 | if (is_host $obj) { | ||||
| 5965 | 97 97 | 87 137 | for my $subnet (@{ $obj->{subnets} }) { | ||||
| 5966 | |||||||
| 5967 | # Handle special case, where network and subnet | ||||||
| 5968 | # have identical address. | ||||||
| 5969 | # E.g. range = 10.1.1.0-10.1.1.255. | ||||||
| 5970 | # Convert subnet to network, because | ||||||
| 5971 | # - different objects with identical IP | ||||||
| 5972 | # can't be checked and optimized properly, | ||||||
| 5973 | # - find_chains would fail, when building binary tree. | ||||||
| 5974 | 103 | 283 | if ($subnet->{mask} == $subnet->{network}->{mask}) { | ||||
| 5975 | 1 | 2 | my $network = $subnet->{network}; | ||||
| 5976 | 1 | 5 | if (not $network->{has_id_hosts} and | ||||
| 5977 | not $subnet_warning_seen{$subnet}++) | ||||||
| 5978 | { | ||||||
| 5979 | 1 | 9 | warn_msg("Use $network->{name} instead of", | ||||
| 5980 | " $subnet->{name}\n", | ||||||
| 5981 | " because both have identical address"); | ||||||
| 5982 | } | ||||||
| 5983 | 1 | 4 | push @other, $network; | ||||
| 5984 | } | ||||||
| 5985 | elsif (my $host = $subnet2host{$subnet}) { | ||||||
| 5986 | 0 | 0 | warn_msg("$obj->{name} and $host->{name}", | ||||
| 5987 | " overlap in $context"); | ||||||
| 5988 | } | ||||||
| 5989 | else { | ||||||
| 5990 | 102 | 149 | $subnet2host{$subnet} = $obj; | ||||
| 5991 | 102 | 231 | push @subnets, $subnet; | ||||
| 5992 | } | ||||||
| 5993 | } | ||||||
| 5994 | } | ||||||
| 5995 | else { | ||||||
| 5996 | 655 | 989 | push @other, $obj; | ||||
| 5997 | } | ||||||
| 5998 | } | ||||||
| 5999 | 596 | 801 | push @other, ($convert_hosts eq 'no_combine') | ||||
| 6000 | ? @subnets | ||||||
| 6001 | 596 | 858 | : @{ combine_subnets \@subnets }; | ||||
| 6002 | 596 | 1207 | return \@other; | ||||
| 6003 | } | ||||||
| 6004 | else { | ||||||
| 6005 | 6 | 12 | return $aref; | ||||
| 6006 | } | ||||||
| 6007 | |||||||
| 6008 | } | ||||||
| 6009 | |||||||
| 6010 | sub check_unused_groups { | ||||||
| 6011 | my $check = sub { | ||||||
| 6012 | 452 | 432 | my ($hash, $print_type) = @_; | ||||
| 6013 | 452 | 1027 | my $print = $print_type eq 'warn' ? \&warn_msg : \&err_msg; | ||||
| 6014 | 452 | 1159 | for my $name (sort keys %$hash) { | ||||
| 6015 | 2 | 3 | my $value = $hash->{$name}; | ||||
| 6016 | 2 | 8 | next if $value->{is_used}; | ||||
| 6017 | 0 | 0 | $print->("unused $value->{name}"); | ||||
| 6018 | } | ||||||
| 6019 | 226 | 0 | 750 | }; | |||
| 6020 | 226 | 478 | if (my $conf = $config{check_unused_groups}) { | ||||
| 6021 | 226 | 307 | for my $hash (\%groups, \%protocolgroups) { | ||||
| 6022 | 452 | 890 | $check->($hash, $conf); | ||||
| 6023 | } | ||||||
| 6024 | } | ||||||
| 6025 | 226 | 453 | if (my $conf = $config{check_unused_protocols}) { | ||||
| 6026 | 0 | 0 | for my $hash (\%protocols) { | ||||
| 6027 | 0 | 0 | $check->($hash, $conf); | ||||
| 6028 | } | ||||||
| 6029 | } | ||||||
| 6030 | |||||||
| 6031 | # Not used any longer; free memory. | ||||||
| 6032 | 226 | 275 | %groups = (); | ||||
| 6033 | 226 | 1166 | return; | ||||
| 6034 | } | ||||||
| 6035 | |||||||
| 6036 | # Result: | ||||||
| 6037 | # Reference to array with elements | ||||||
| 6038 | # - non TCP/UDP protocol | ||||||
| 6039 | # - dst_range of (splitted) TCP/UDP protocol | ||||||
| 6040 | # - [ src_range, dst_range, orig_prt ] | ||||||
| 6041 | # of (splitted) protocol having src_range or main_prt. | ||||||
| 6042 | sub expand_protocols { | ||||||
| 6043 | 333 | 0 | 331 | my ($aref, $context) = @_; | |||
| 6044 | 333 | 260 | my @protocols; | ||||
| 6045 | 333 | 379 | for my $pair (@$aref) { | ||||
| 6046 | |||||||
| 6047 | # Handle anonymous protocol. | ||||||
| 6048 | 354 | 650 | if (ref($pair) eq 'HASH') { | ||||
| 6049 | 322 | 344 | push @protocols, $pair; | ||||
| 6050 | 322 | 462 | next; | ||||
| 6051 | } | ||||||
| 6052 | |||||||
| 6053 | 32 | 41 | my ($type, $name) = @$pair; | ||||
| 6054 | 32 | 64 | if ($type eq 'protocol') { | ||||
| 6055 | 31 | 61 | if (my $prt = $protocols{$name}) { | ||||
| 6056 | 31 | 31 | push @protocols, $prt; | ||||
| 6057 | |||||||
| 6058 | # Currently needed by external program 'cut-netspoc'. | ||||||
| 6059 | 31 | 68 | $prt->{is_used} = 1; | ||||
| 6060 | } | ||||||
| 6061 | else { | ||||||
| 6062 | 0 | 0 | err_msg("Can't resolve reference to $type:$name in $context"); | ||||
| 6063 | 0 | 0 | next; | ||||
| 6064 | } | ||||||
| 6065 | } | ||||||
| 6066 | elsif ($type eq 'protocolgroup') { | ||||||
| 6067 | 1 | 3 | if (my $prtgroup = $protocolgroups{$name}) { | ||||
| 6068 | 1 | 1 | my $elements = $prtgroup->{elements}; | ||||
| 6069 | 1 | 4 | if ($elements eq 'recursive') { | ||||
| 6070 | 0 | 0 | err_msg("Found recursion in definition of $context"); | ||||
| 6071 | 0 | 0 | $prtgroup->{elements} = $elements = []; | ||||
| 6072 | } | ||||||
| 6073 | |||||||
| 6074 | # Check if it has already been converted | ||||||
| 6075 | # from names to references. | ||||||
| 6076 | elsif (not $prtgroup->{is_used}) { | ||||||
| 6077 | |||||||
| 6078 | # Detect recursive definitions. | ||||||
| 6079 | 1 | 2 | $prtgroup->{elements} = 'recursive'; | ||||
| 6080 | 1 | 1 | $prtgroup->{is_used} = 1; | ||||
| 6081 | 1 | 7 | $elements = expand_protocols($elements, "$type:$name"); | ||||
| 6082 | |||||||
| 6083 | # Cache result for further references to the same group. | ||||||
| 6084 | 1 | 2 | $prtgroup->{elements} = $elements; | ||||
| 6085 | } | ||||||
| 6086 | |||||||
| 6087 | # Split only once. | ||||||
| 6088 | 1 | 2 | push @protocols, @$elements; | ||||
| 6089 | } | ||||||
| 6090 | else { | ||||||
| 6091 | 0 | 0 | err_msg("Can't resolve reference to $type:$name in $context"); | ||||
| 6092 | 0 | 0 | next; | ||||
| 6093 | } | ||||||
| 6094 | } | ||||||
| 6095 | else { | ||||||
| 6096 | 0 | 0 | err_msg("Unknown type of $type:$name in $context"); | ||||
| 6097 | } | ||||||
| 6098 | } | ||||||
| 6099 | 333 | 690 | return \@protocols; | ||||
| 6100 | } | ||||||
| 6101 | |||||||
| 6102 | # Expand splitted protocols. | ||||||
| 6103 | sub split_protocols { | ||||||
| 6104 | 319 | 0 | 300 | my ($protocols, $context) = @_; | |||
| 6105 | 319 | 252 | my @splitted_protocols; | ||||
| 6106 | 319 | 359 | for my $prt (@$protocols) { | ||||
| 6107 | 340 | 348 | my $proto = $prt->{proto}; | ||||
| 6108 | 340 | 820 | if (not($proto eq 'tcp' or $proto eq 'udp')) { | ||||
| 6109 | 76 | 81 | push @splitted_protocols, $prt; | ||||
| 6110 | 76 | 120 | next; | ||||
| 6111 | } | ||||||
| 6112 | |||||||
| 6113 | # Collect splitted src_range / dst_range pairs. | ||||||
| 6114 | 264 | 251 | my $dst_range = $prt->{dst_range}; | ||||
| 6115 | 264 | 240 | my $src_range = $prt->{src_range}; | ||||
| 6116 | |||||||
| 6117 | # Remember original protocol as third value | ||||||
| 6118 | # - if src_range is given or | ||||||
| 6119 | # - if original protocol has flags or | ||||||
| 6120 | # - if $dst_range is shared between different protocols. | ||||||
| 6121 | # Cache list of triples at original protocol for re-use. | ||||||
| 6122 | 264 | 1679 | if ($src_range or $prt->{flags} or $dst_range->{name} ne $prt->{name}) { | ||||
| 6123 | 28 | 34 | my $aref_list = $prt->{src_dst_range_list}; | ||||
| 6124 | 28 | 45 | if (not $aref_list) { | ||||
| 6125 | 26 | 41 | for my $src_split (expand_splitted_protocol $src_range) { | ||||
| 6126 | 26 | 36 | for my $dst_split (expand_splitted_protocol $dst_range) { | ||||
| 6127 | 26 | 78 | push @$aref_list, [$src_split, $dst_split, $prt]; | ||||
| 6128 | } | ||||||
| 6129 | } | ||||||
| 6130 | 26 | 38 | $prt->{src_dst_range_list} = $aref_list; | ||||
| 6131 | } | ||||||
| 6132 | 28 | 50 | push @splitted_protocols, @$aref_list; | ||||
| 6133 | } | ||||||
| 6134 | else { | ||||||
| 6135 | 236 | 316 | for my $dst_split (expand_splitted_protocol $dst_range) { | ||||
| 6136 | 237 | 596 | push @splitted_protocols, $dst_split; | ||||
| 6137 | } | ||||||
| 6138 | } | ||||||
| 6139 | } | ||||||
| 6140 | 319 | 458 | return \@splitted_protocols; | ||||
| 6141 | } | ||||||
| 6142 | |||||||
| 6143 | sub path_auto_interfaces; | ||||||
| 6144 | |||||||
| 6145 | # Hash with attributes deny, supernet, permit for storing | ||||||
| 6146 | # expanded rules of different type. | ||||||
| 6147 | our %expanded_rules; | ||||||
| 6148 | |||||||
| 6149 | # Hash for ordering all rules. | ||||||
| 6150 | # Put attributes with small value set first, to get a more | ||||||
| 6151 | # memory efficient tree with few branches at root. | ||||||
| 6152 | # $rule_tree{$stateless}->{$deny}->{$src_range}->{$src}->{$dst}->{$prt} | ||||||
| 6153 | # = $rule; | ||||||
| 6154 | my %rule_tree; | ||||||
| 6155 | |||||||
| 6156 | # Collect deleted rules for further inspection. | ||||||
| 6157 | my @deleted_rules; | ||||||
| 6158 | |||||||
| 6159 | # Add rules to %rule_tree for efficient look up. | ||||||
| 6160 | sub add_rules { | ||||||
| 6161 | 1020 | 0 | 889 | my ($rules_ref, $rule_tree) = @_; | |||
| 6162 | 1020 | 1888 | $rule_tree ||= \%rule_tree; | ||||
| 6163 | |||||||
| 6164 | 1020 | 1095 | for my $rule (@$rules_ref) { | ||||
| 6165 | 630 | 1055 | my ($stateless, $deny, $src, $dst, $src_range, $prt) = | ||||
| 6166 | 630 | 889 | @{$rule}{ qw(stateless deny src dst src_range prt) }; | ||||
| 6167 | |||||||
| 6168 | # A rule with an interface as destination may be marked as deleted | ||||||
| 6169 | # during global optimization. But in some cases, code for this rule | ||||||
| 6170 | # must be generated anyway. This happens, if | ||||||
| 6171 | # - it is an interface of a managed router and | ||||||
| 6172 | # - code is generated for exactly this router. | ||||||
| 6173 | # Mark such rules for easier handling. | ||||||
| 6174 | 630 | 756 | if (is_interface($dst) && ($dst->{router}->{managed} || | ||||
| 6175 | $dst->{router}->{routing_only})) | ||||||
| 6176 | { | ||||||
| 6177 | 125 | 144 | $rule->{managed_intf} = 1; | ||||
| 6178 | } | ||||||
| 6179 | 630 | 1450 | $stateless ||= ''; | ||||
| 6180 | 630 | 1362 | $deny ||= ''; | ||||
| 6181 | 630 | 1287 | $src_range ||= $prt_ip; | ||||
| 6182 | 630 | 2030 | my $old_rule = | ||||
| 6183 | $rule_tree->{$stateless}->{$deny}->{$src_range}->{$src}->{$dst} | ||||||
| 6184 | ->{$prt}; | ||||||
| 6185 | 630 | 854 | if ($old_rule) { | ||||
| 6186 | |||||||
| 6187 | # Found identical rule. | ||||||
| 6188 | 7 | 6 | $rule->{deleted} = $old_rule; | ||||
| 6189 | 7 | 6 | push @deleted_rules, $rule; | ||||
| 6190 | 7 | 12 | next; | ||||
| 6191 | } | ||||||
| 6192 | |||||||
| 6193 | # debug("Add:", print_rule $rule); | ||||||
| 6194 | 623 | 2148 | $rule_tree->{$stateless}->{$deny}->{$src_range}->{$src}->{$dst} | ||||
| 6195 | ->{$prt} = $rule; | ||||||
| 6196 | } | ||||||
| 6197 | 1020 | 1046 | return; | ||||
| 6198 | } | ||||||
| 6199 | |||||||
| 6200 | my %obj2zone; | ||||||
| 6201 | |||||||
| 6202 | sub get_zone { | ||||||
| 6203 | 780 | 0 | 673 | my ($obj) = @_; | |||
| 6204 | 780 | 767 | my $type = ref $obj; | ||||
| 6205 | 780 | 564 | my $result; | ||||
| 6206 | |||||||
| 6207 | # A router or network with [auto] interface. | ||||||
| 6208 | 780 | 1132 | if ($type eq 'Autointerface') { | ||||
| 6209 | 21 | 20 | $obj = $obj->{object}; | ||||
| 6210 | 21 | 22 | $type = ref $obj; | ||||
| 6211 | } | ||||||
| 6212 | |||||||
| 6213 | 780 | 1138 | if ($type eq 'Network') { | ||||
| 6214 | 589 | 580 | $result = $obj->{zone}; | ||||
| 6215 | } | ||||||
| 6216 | elsif ($type eq 'Subnet') { | ||||||
| 6217 | 93 | 121 | $result = $obj->{network}->{zone}; | ||||
| 6218 | } | ||||||
| 6219 | elsif ($type eq 'Interface') { | ||||||
| 6220 | 82 | 142 | if ($obj->{router}->{managed}) { | ||||
| 6221 | 57 | 59 | $result = $obj->{router}; | ||||
| 6222 | } | ||||||
| 6223 | else { | ||||||
| 6224 | 25 | 29 | $result = $obj->{network}->{zone}; | ||||
| 6225 | } | ||||||
| 6226 | } | ||||||
| 6227 | |||||||
| 6228 | # Only used when called from expand_rules. | ||||||
| 6229 | elsif ($type eq 'Router') { | ||||||
| 6230 | 16 | 22 | if ($obj->{managed}) { | ||||
| 6231 | 7 | 7 | $result = $obj; | ||||
| 6232 | } | ||||||
| 6233 | else { | ||||||
| 6234 | 9 | 15 | $result = $obj->{interfaces}->[0]->{network}->{zone}; | ||||
| 6235 | } | ||||||
| 6236 | } | ||||||
| 6237 | elsif ($type eq 'Host') { | ||||||
| 6238 | 0 | 0 | $result = $obj->{network}->{zone}; | ||||
| 6239 | } | ||||||
| 6240 | else { | ||||||
| 6241 | 0 | 0 | internal_err("unexpected $obj->{name}"); | ||||
| 6242 | } | ||||||
| 6243 | 780 | 2066 | return($obj2zone{$obj} = $result); | ||||
| 6244 | } | ||||||
| 6245 | |||||||
| 6246 | sub path_walk; | ||||||
| 6247 | |||||||
| 6248 | sub expand_special { | ||||||
| 6249 | 958 | 0 | 1318 | my ($src, $dst, $flags, $context) = @_; | |||
| 6250 | 958 | 690 | my @result; | ||||
| 6251 | 958 | 1070 | if (is_autointerface $src) { | ||||
| 6252 | 21 | 28 | for my $interface (path_auto_interfaces $src, $dst) { | ||||
| 6253 | 34 | 64 | if ($interface->{ip} eq 'short') { | ||||
| 6254 | 0 | 0 | err_msg "'$interface->{ip}' $interface->{name}", | ||||
| 6255 | " (from .[auto])\n", " must not be used in rule of $context"; | ||||||
| 6256 | } | ||||||
| 6257 | elsif ($interface->{ip} eq 'unnumbered') { | ||||||
| 6258 | |||||||
| 6259 | # Ignore unnumbered interfaces. | ||||||
| 6260 | } | ||||||
| 6261 | else { | ||||||
| 6262 | 34 | 45 | push @result, $interface; | ||||
| 6263 | } | ||||||
| 6264 | } | ||||||
| 6265 | } | ||||||
| 6266 | else { | ||||||
| 6267 | 937 | 986 | @result = ($src); | ||||
| 6268 | } | ||||||
| 6269 | 958 | 1620 | if ($flags->{net}) { | ||||
| 6270 | 4 | 5 | my @networks; | ||||
| 6271 | my @other; | ||||||
| 6272 | 4 | 6 | for my $obj (@result) { | ||||
| 6273 | 4 | 4 | my $type = ref $obj; | ||||
| 6274 | 4 | 3 | my $network; | ||||
| 6275 | 4 | 17 | if ($type eq 'Network') { | ||||
| 6276 | 0 | 0 | $network = $obj; | ||||
| 6277 | } | ||||||
| 6278 | elsif ($type eq 'Subnet' or $type eq 'Host') { | ||||||
| 6279 | 3 | 5 | if ($obj->{id}) { | ||||
| 6280 | 0 | 0 | push @other, $obj; | ||||
| 6281 | 0 | 0 | next; | ||||
| 6282 | } | ||||||
| 6283 | else { | ||||||
| 6284 | 3 | 4 | $network = $obj->{network}; | ||||
| 6285 | } | ||||||
| 6286 | } | ||||||
| 6287 | elsif ($type eq 'Interface') { | ||||||
| 6288 | 1 | 3 | if ($obj->{router}->{managed} || $obj->{loopback}) { | ||||
| 6289 | 1 | 2 | push @other, $obj; | ||||
| 6290 | 1 | 2 | next; | ||||
| 6291 | } | ||||||
| 6292 | else { | ||||||
| 6293 | 0 | 0 | $network = $obj->{network}; | ||||
| 6294 | } | ||||||
| 6295 | } | ||||||
| 6296 | else { | ||||||
| 6297 | 0 | 0 | internal_err("unexpected $obj->{name}"); | ||||
| 6298 | } | ||||||
| 6299 | 3 | 10 | push @networks, $network if $network->{ip} ne 'unnumbered'; | ||||
| 6300 | } | ||||||
| 6301 | 4 | 7 | @result = (@other, unique(@networks)); | ||||
| 6302 | # debug "special: ", join(', ', map { $_->{name} } @result); | ||||||
| 6303 | } | ||||||
| 6304 | 958 | 1306 | if ($flags->{any}) { | ||||
| 6305 | 0 | 0 | my %zones; | ||||
| 6306 | 0 | 0 | for my $obj (@result) { | ||||
| 6307 | 0 | 0 | my $type = ref $obj; | ||||
| 6308 | 0 | 0 | my $zone; | ||||
| 6309 | 0 | 0 | if ($type eq 'Network') { | ||||
| 6310 | 0 | 0 | $zone = $obj->{zone}; | ||||
| 6311 | } | ||||||
| 6312 | elsif ($type eq 'Subnet' or $type eq 'Interface' or $type eq 'Host') | ||||||
| 6313 | { | ||||||
| 6314 | 0 | 0 | $zone = $obj->{network}->{zone}; | ||||
| 6315 | } | ||||||
| 6316 | else { | ||||||
| 6317 | 0 | 0 | internal_err("unexpected $obj->{name}"); | ||||
| 6318 | } | ||||||
| 6319 | 0 | 0 | $zones{$zone} = $zone; | ||||
| 6320 | } | ||||||
| 6321 | 0 0 | 0 0 | @result = map { get_any($_, 0, 0) } values %zones; | ||||
| 6322 | } | ||||||
| 6323 | 958 | 1853 | return @result; | ||||
| 6324 | } | ||||||
| 6325 | |||||||
| 6326 | # Add managed hosts of networks and aggregates. | ||||||
| 6327 | sub add_managed_hosts { | ||||||
| 6328 | 298 | 0 | 310 | my ($aref, $context) = @_; | |||
| 6329 | 298 | 239 | my @extra; | ||||
| 6330 | 298 | 336 | for my $object (@$aref) { | ||||
| 6331 | 368 | 878 | my $managed_hosts = $object->{managed_hosts} or next; | ||||
| 6332 | 5 | 8 | push @extra, @$managed_hosts; | ||||
| 6333 | } | ||||||
| 6334 | 298 | 524 | if (@extra) { | ||||
| 6335 | 5 | 5 | push @$aref, @extra; | ||||
| 6336 | 5 | 7 | $aref = remove_duplicates($aref, $context); | ||||
| 6337 | } | ||||||
| 6338 | 298 | 343 | return $aref; | ||||
| 6339 | } | ||||||
| 6340 | |||||||
| 6341 | # This handles a rule between objects inside a single security zone or | ||||||
| 6342 | # between interfaces of a single managed router. | ||||||
| 6343 | # Show warning or error message if rule is between | ||||||
| 6344 | # - different interfaces or | ||||||
| 6345 | # - different networks or | ||||||
| 6346 | # - subnets/hosts of different networks. | ||||||
| 6347 | # Rules between identical objects are silently ignored. | ||||||
| 6348 | # But a message is shown if a service only has rules between identical objects. | ||||||
| 6349 | sub collect_unenforceable { | ||||||
| 6350 | 23 | 0 | 23 | my ($src, $dst, $zone, $service) = @_; | |||
| 6351 | |||||||
| 6352 | 23 | 43 | if ($zone->{has_unenforceable}) { | ||||
| 6353 | 2 | 3 | $zone->{seen_unenforceable} = 1; | ||||
| 6354 | 2 | 7 | $service->{silent_unenforceable} = 1; | ||||
| 6355 | 2 | 2 | return; | ||||
| 6356 | } | ||||||
| 6357 | |||||||
| 6358 | 21 | 21 | my $context = $service->{name}; | ||||
| 6359 | 21 | 24 | $service->{silent_unenforceable} = 1; | ||||
| 6360 | |||||||
| 6361 | # A rule between identical objects is a common case | ||||||
| 6362 | # which results from rules with "src=user;dst=user;". | ||||||
| 6363 | 21 | 47 | return if $src eq $dst; | ||||
| 6364 | |||||||
| 6365 | 8 | 11 | if (is_router $zone) { | ||||
| 6366 | |||||||
| 6367 | # Auto interface is assumed to be identical | ||||||
| 6368 | # to each other interface of a single router. | ||||||
| 6369 | 0 | 0 | return if is_autointerface($src) or is_autointerface($dst); | ||||
| 6370 | } | ||||||
| 6371 | elsif (is_subnet $src and is_subnet($dst)) { | ||||||
| 6372 | |||||||
| 6373 | # For rules with different subnets of a single network we don't | ||||||
| 6374 | # know if the subnets have been split from a single range. | ||||||
| 6375 | # E.g. range 1-4 becomes four subnets 1,2-3,4 | ||||||
| 6376 | # For most splits the resulting subnets would be adjacent. | ||||||
| 6377 | # Hence we check for adjacency. | ||||||
| 6378 | 2 | 6 | if ($src->{network} eq $dst->{network}) { | ||||
| 6379 | 2 | 4 | my ($a, $b) = $src->{ip} > $dst->{ip} ? ($dst, $src) : ($src, $dst); | ||||
| 6380 | 2 | 3 | if ($a->{ip} + complement_32bit($a->{mask}) + 1 == $b->{ip}) { | ||||
| 6381 | 0 | 0 | return; | ||||
| 6382 | } | ||||||
| 6383 | } | ||||||
| 6384 | } | ||||||
| 6385 | elsif ($src->{is_aggregate} && $dst->{is_aggregate}) { | ||||||
| 6386 | |||||||
| 6387 | # Both are aggregates, | ||||||
| 6388 | # - belonging to same zone cluster and | ||||||
| 6389 | # - having identical ip and mask | ||||||
| 6390 | 0 | 0 | return if (zone_eq($src->{zone}, $dst->{zone}) | ||||
| 6391 | && $src->{ip} == $dst->{ip} | ||||||
| 6392 | && $src->{mask} == $dst->{mask}); | ||||||
| 6393 | } | ||||||
| 6394 | elsif ($src->{is_aggregate} && $src->{mask} == 0) { | ||||||
| 6395 | |||||||
| 6396 | # This is a common case, which results from rules like | ||||||
| 6397 | # group:some_networks -> any:[group:some_networks] | ||||||
| 6398 | 0 | 0 | return if zone_eq($src->{zone}, get_zone($dst)) | ||||
| 6399 | } | ||||||
| 6400 | elsif ($dst->{is_aggregate} && $dst->{mask} == 0 ) { | ||||||
| 6401 | 3 | 5 | return if zone_eq($dst->{zone}, get_zone($src)) | ||||
| 6402 | } | ||||||
| 6403 | elsif ($dst->{managed_hosts}) { | ||||||
| 6404 | |||||||
| 6405 | # Network or aggregate was only used for its managed_hosts | ||||||
| 6406 | # to be added automatically in expand_group. | ||||||
| 6407 | 0 | 0 | return; | ||||
| 6408 | } | ||||||
| 6409 | 5 | 28 | $service->{seen_unenforceable}->{$src}->{$dst} ||= [ $src, $dst ]; | ||||
| 6410 | 5 | 8 | return; | ||||
| 6411 | } | ||||||
| 6412 | |||||||
| 6413 | sub show_unenforceable { | ||||||
| 6414 | 261 | 0 | 265 | my ($service) = @_; | |||
| 6415 | 261 | 284 | my $context = $service->{name}; | ||||
| 6416 | |||||||
| 6417 | 261 | 525 | if ($service->{has_unenforceable} && | ||||
| 6418 | (! $service->{seen_unenforceable} || ! $service->{seen_enforceable})) | ||||||
| 6419 | { | ||||||
| 6420 | 1 | 4 | warn_msg("Useless attribute 'has_unenforceable' at $context"); | ||||
| 6421 | } | ||||||
| 6422 | 261 | 479 | return if ! $config{check_unenforceable}; | ||||
| 6423 | 261 | 399 | return if $service->{disabled}; | ||||
| 6424 | |||||||
| 6425 | 261 | 493 | my $print = $config{check_unenforceable} eq 'warn' ? \&warn_msg : \&err_msg; | ||||
| 6426 | |||||||
| 6427 | # Warning about fully unenforceable service can't be disabled with | ||||||
| 6428 | # attribute has_unenforceable. | ||||||
| 6429 | 261 | 559 | if (! delete $service->{seen_enforceable}) { | ||||
| 6430 | |||||||
| 6431 | # Don't warn on empty service without any expanded rules. | ||||||
| 6432 | 5 | 24 | if ($service->{seen_unenforceable} || $service->{silent_unenforceable}) | ||||
| 6433 | { | ||||||
| 6434 | 3 | 10 | $print->("$context is fully unenforceable"); | ||||
| 6435 | } | ||||||
| 6436 | 5 | 8 | return; | ||||
| 6437 | } | ||||||
| 6438 | 256 | 407 | return if $service->{has_unenforceable}; | ||||
| 6439 | |||||||
| 6440 | 255 | 450 | if (my $hash = delete $service->{seen_unenforceable}) { | ||||
| 6441 | 1 | 2 | my $msg = "$context has unenforceable rules:"; | ||||
| 6442 | 1 | 2 | for my $hash (values %$hash) { | ||||
| 6443 | 1 | 2 | for my $aref (values %$hash) { | ||||
| 6444 | 1 | 1 | my ($src, $dst) = @$aref; | ||||
| 6445 | 1 | 5 | $msg .= "\n src=$src->{name}; dst=$dst->{name}"; | ||||
| 6446 | } | ||||||
| 6447 | } | ||||||
| 6448 | 1 | 2 | $print->($msg); | ||||
| 6449 | } | ||||||
| 6450 | 255 | 250 | delete $service->{silent_unenforceable}; | ||||
| 6451 | 255 | 322 | return; | ||||
| 6452 | } | ||||||
| 6453 | |||||||
| 6454 | sub warn_useless_unenforceable { | ||||||
| 6455 | 315 | 0 | 364 | for my $zone (@zones) { | |||
| 6456 | 825 | 1408 | $zone->{has_unenforceable} or next; | ||||
| 6457 | 2 | 5 | $zone->{seen_unenforceable} and next; | ||||
| 6458 | 1 | 2 | my $agg00 = $zone->{ipmask2aggregate}->{'0/0'}; | ||||
| 6459 | 1 | 2 | my $name = $agg00 ? $agg00->{name} : $zone->{name}; | ||||
| 6460 | 1 | 3 | warn_msg("Useless attribute 'has_unenforceable' at $name"); | ||||
| 6461 | } | ||||||
| 6462 | 315 | 297 | return; | ||||
| 6463 | } | ||||||
| 6464 | |||||||
| 6465 | sub show_deleted_rules1 { | ||||||
| 6466 | 315 | 0 | 522 | return if not @deleted_rules; | |||
| 6467 | 1 | 2 | my %sname2oname2deleted; | ||||
| 6468 | RULE: | ||||||
| 6469 | 1 | 1 | for my $rule (@deleted_rules) { | ||||
| 6470 | 1 | 4 | my $other = $rule->{deleted}; | ||||
| 6471 | |||||||
| 6472 | 1 | 4 | my $prt1 = $rule->{orig_prt} || $rule->{prt}; | ||||
| 6473 | 1 | 4 | my $prt2 = $other->{orig_prt} || $other->{prt}; | ||||
| 6474 | 1 | 3 | next if $prt1->{flags}->{overlaps} && $prt2->{flags}->{overlaps}; | ||||
| 6475 | |||||||
| 6476 | 1 | 2 | my $service = $rule->{rule}->{service}; | ||||
| 6477 | 1 | 1 | my $oservice = $other->{rule}->{service}; | ||||
| 6478 | 1 | 2 | if (my $overlaps = $service->{overlaps}) { | ||||
| 6479 | 1 | 2 | for my $overlap (@$overlaps) { | ||||
| 6480 | 1 | 2 | if ($oservice eq $overlap) { | ||||
| 6481 | 1 | 3 | $service->{overlaps_used}->{$overlap} = $overlap; | ||||
| 6482 | 1 | 3 | next RULE; | ||||
| 6483 | } | ||||||
| 6484 | } | ||||||
| 6485 | } | ||||||
| 6486 | 0 | 0 | if (my $overlaps = $oservice->{overlaps}) { | ||||
| 6487 | 0 | 0 | for my $overlap (@$overlaps) { | ||||
| 6488 | 0 | 0 | if ($service eq $overlap) { | ||||
| 6489 | 0 | 0 | $oservice->{overlaps_used}->{$overlap} = $overlap; | ||||
| 6490 | 0 | 0 | next RULE; | ||||
| 6491 | } | ||||||
| 6492 | } | ||||||
| 6493 | } | ||||||
| 6494 | 0 | 0 | my $sname = $service->{name}; | ||||
| 6495 | 0 | 0 | my $oname = $oservice->{name}; | ||||
| 6496 | 0 | 0 | my $pfile = $service->{file}; | ||||
| 6497 | 0 | 0 | my $ofile = $oservice->{file}; | ||||
| 6498 | 0 | 0 | $pfile =~ s/.*?([^\/]+)$/$1/; | ||||
| 6499 | 0 | 0 | $ofile =~ s/.*?([^\/]+)$/$1/; | ||||
| 6500 | 0 0 | 0 0 | push(@{ $sname2oname2deleted{$sname}->{$oname} }, $rule); | ||||
| 6501 | } | ||||||
| 6502 | 1 | 3 | if (my $action = $config{check_duplicate_rules}) { | ||||
| 6503 | 1 | 2 | my $print = $action eq 'warn' ? \&warn_msg : \&err_msg; | ||||
| 6504 | 1 | 3 | for my $sname (sort keys %sname2oname2deleted) { | ||||
| 6505 | 0 | 0 | my $hash = $sname2oname2deleted{$sname}; | ||||
| 6506 | 0 | 0 | for my $oname (sort keys %$hash) { | ||||
| 6507 | 0 | 0 | my $aref = $hash->{$oname}; | ||||
| 6508 | 0 | 0 | my $msg = "Duplicate rules in $sname and $oname:\n "; | ||||
| 6509 | 0 0 | 0 0 | $msg .= join("\n ", map { print_rule $_ } @$aref); | ||||
| 6510 | 0 | 0 | $print->($msg); | ||||
| 6511 | } | ||||||
| 6512 | } | ||||||
| 6513 | } | ||||||
| 6514 | |||||||
| 6515 | # Variable will be reused during sub optimize. | ||||||
| 6516 | 1 | 2 | @deleted_rules = (); | ||||
| 6517 | 1 | 1 | return; | ||||
| 6518 | } | ||||||
| 6519 | |||||||
| 6520 | sub collect_redundant_rules { | ||||||
| 6521 | 32 | 0 | 32 | my ($rule, $other) = @_; | |||
| 6522 | |||||||
| 6523 | # Ignore automatically generated rules from crypto or from reverse rules. | ||||||
| 6524 | 32 | 60 | return if !$rule->{rule}; | ||||
| 6525 | 24 | 37 | return if !$other->{rule}; | ||||
| 6526 | |||||||
| 6527 | 24 | 64 | my $prt1 = $rule->{orig_prt} || $rule->{prt}; | ||||
| 6528 | 24 | 60 | my $prt2 = $other->{orig_prt} || $other->{prt}; | ||||
| 6529 | 24 | 61 | return if $prt1->{flags}->{overlaps} && $prt2->{flags}->{overlaps}; | ||||
| 6530 | |||||||
| 6531 | # Rule is still needed at device of $rule->{dst}. | ||||||
| 6532 | 24 | 48 | if ($rule->{managed_intf} and not $rule->{deleted}->{managed_intf}) { | ||||
| 6533 | 1 | 1 | return; | ||||
| 6534 | } | ||||||
| 6535 | |||||||
| 6536 | # Automatically generated reverse rule for stateless router | ||||||
| 6537 | # is still needed, even for stateful routers for static routes. | ||||||
| 6538 | 23 | 25 | my $src = $rule->{src}; | ||||
| 6539 | 23 | 29 | if (is_interface($src)) { | ||||
| 6540 | 0 | 0 | my $router = $src->{router}; | ||||
| 6541 | 0 | 0 | if ($router->{managed} || $router->{routing_only}) { | ||||
| 6542 | 0 | 0 | return; | ||||
| 6543 | } | ||||||
| 6544 | } | ||||||
| 6545 | |||||||
| 6546 | 23 | 30 | my $service = $rule->{rule}->{service}; | ||||
| 6547 | 23 | 22 | my $oservice = $other->{rule}->{service}; | ||||
| 6548 | 23 | 41 | if (!$oservice) { | ||||
| 6549 | 0 | 0 | debug "d:", print_rule $rule; | ||||
| 6550 | 0 | 0 | debug "o:", print_rule $other; | ||||
| 6551 | } | ||||||
| 6552 | 23 | 43 | if (my $overlaps = $service->{overlaps}) { | ||||
| 6553 | 4 | 4 | for my $overlap (@$overlaps) { | ||||
| 6554 | 4 | 10 | if ($oservice eq $overlap) { | ||||
| 6555 | 3 | 7 | $service->{overlaps_used}->{$overlap} = $overlap; | ||||
| 6556 | 3 | 4 | return; | ||||
| 6557 | } | ||||||
| 6558 | } | ||||||
| 6559 | } | ||||||
| 6560 | 20 | 27 | push @deleted_rules, [ $rule, $other ]; | ||||
| 6561 | 20 | 25 | return; | ||||
| 6562 | } | ||||||
| 6563 | |||||||
| 6564 | sub show_deleted_rules2 { | ||||||
| 6565 | 226 | 0 | 361 | return if not @deleted_rules; | |||
| 6566 | 13 | 14 | my %sname2oname2deleted; | ||||
| 6567 | 13 | 15 | for my $pair (@deleted_rules) { | ||||
| 6568 | 20 | 24 | my ($rule, $other) = @$pair; | ||||
| 6569 | |||||||
| 6570 | 20 | 22 | my $service = $rule->{rule}->{service}; | ||||
| 6571 | 20 | 22 | my $oservice = $other->{rule}->{service}; | ||||
| 6572 | 20 | 23 | my $sname = $service->{name}; | ||||
| 6573 | 20 | 18 | my $oname = $oservice->{name}; | ||||
| 6574 | 20 | 20 | my $pfile = $service->{file}; | ||||
| 6575 | 20 | 19 | my $ofile = $oservice->{file}; | ||||
| 6576 | 20 | 199 | $pfile =~ s/.*?([^\/]+)$/$1/; | ||||
| 6577 | 20 | 166 | $ofile =~ s/.*?([^\/]+)$/$1/; | ||||
| 6578 | 20 20 | 22 80 | push(@{ $sname2oname2deleted{$sname}->{$oname} }, [ $rule, $other ]); | ||||
| 6579 | } | ||||||
| 6580 | 13 | 32 | if (my $action = $config{check_redundant_rules}) { | ||||
| 6581 | 11 | 21 | my $print = $action eq 'warn' ? \&warn_msg : \&err_msg; | ||||
| 6582 | 11 | 28 | for my $sname (sort keys %sname2oname2deleted) { | ||||
| 6583 | 15 | 19 | my $hash = $sname2oname2deleted{$sname}; | ||||
| 6584 | 15 | 36 | for my $oname (sort keys %$hash) { | ||||
| 6585 | 17 | 22 | my $aref = $hash->{$oname}; | ||||
| 6586 | 17 | 43 | my $msg = "Redundant rules in $sname compared to $oname:\n "; | ||||
| 6587 | 18 | 19 | $msg .= join( | ||||
| 6588 | "\n ", | ||||||
| 6589 | map { | ||||||
| 6590 | 17 | 25 | my ($r, $o) = @$_; | ||||
| 6591 | 18 | 28 | print_rule($r) . "\n< " . print_rule($o); | ||||
| 6592 | } @$aref | ||||||
| 6593 | ); | ||||||
| 6594 | 17 | 26 | $print->($msg); | ||||
| 6595 | } | ||||||
| 6596 | } | ||||||
| 6597 | } | ||||||
| 6598 | |||||||
| 6599 | # Free memory. | ||||||
| 6600 | 13 | 23 | @deleted_rules = (); | ||||
| 6601 | |||||||
| 6602 | 13 | 31 | return; | ||||
| 6603 | } | ||||||
| 6604 | |||||||
| 6605 | sub warn_unused_overlaps { | ||||||
| 6606 | 226 | 0 | 465 | for my $key (sort keys %services) { | |||
| 6607 | 239 | 309 | my $service = $services{$key}; | ||||
| 6608 | 239 | 386 | next if $service->{disabled}; | ||||
| 6609 | 239 | 538 | if (my $overlaps = $service->{overlaps}) { | ||||
| 6610 | 4 | 5 | my $used = delete $service->{overlaps_used}; | ||||
| 6611 | 4 | 7 | for my $overlap (@$overlaps) { | ||||
| 6612 | 4 | 7 | next if $overlap->{disabled}; | ||||
| 6613 | 4 | 19 | $used->{$overlap} | ||||
| 6614 | or warn_msg("Useless 'overlaps = $overlap->{name}'", | ||||||
| 6615 | " in $service->{name}"); | ||||||
| 6616 | } | ||||||
| 6617 | } | ||||||
| 6618 | } | ||||||
| 6619 | 226 | 232 | return; | ||||
| 6620 | } | ||||||
| 6621 | |||||||
| 6622 | # All log tags defined at some routers. | ||||||
| 6623 | my %known_log; | ||||||
| 6624 | |||||||
| 6625 | sub collect_log { | ||||||
| 6626 | 315 | 0 | 363 | for my $router (@managed_routers) { | |||
| 6627 | 451 | 928 | my $log = $router->{log} or next; | ||||
| 6628 | 19 | 30 | for my $tag (keys %$log) { | ||||
| 6629 | 34 | 61 | $known_log{$tag} = 1; | ||||
| 6630 | } | ||||||
| 6631 | } | ||||||
| 6632 | 315 | 285 | return; | ||||
| 6633 | } | ||||||
| 6634 | |||||||
| 6635 | sub check_log { | ||||||
| 6636 | 18 | 0 | 16 | my ($log, $context) = @_; | |||
| 6637 | 18 | 16 | for my $tag (@$log) { | ||||
| 6638 | 20 | 44 | $known_log{$tag} and next; | ||||
| 6639 | 1 | 4 | warn_msg("Referencing unknown '$tag' in log of $context"); | ||||
| 6640 | 1 | 2 | aref_delete($log, $tag); | ||||
| 6641 | } | ||||||
| 6642 | 18 | 20 | return; | ||||
| 6643 | } | ||||||
| 6644 | |||||||
| 6645 | # Normalize lists of log tags at different rules in such a way, | ||||||
| 6646 | # that equal sets of tags are represented by 'eq' array references. | ||||||
| 6647 | my %key2log; | ||||||
| 6648 | sub normalize_log { | ||||||
| 6649 | 17 | 0 | 14 | my ($log) = @_; | |||
| 6650 | 17 | 29 | my @tags = sort @$log; | ||||
| 6651 | 17 | 25 | my $key = join(',', @tags); | ||||
| 6652 | 17 | 62 | return $key2log{$key} ||= \@tags; | ||||
| 6653 | } | ||||||
| 6654 | |||||||
| 6655 | # Parameters: | ||||||
| 6656 | # - The service. | ||||||
| 6657 | # - Reference to array for storing resulting expanded rules. | ||||||
| 6658 | # - Flag which will be passed on to expand_group. | ||||||
| 6659 | sub expand_rules { | ||||||
| 6660 | 261 | 0 | 276 | my ($service, $result, $convert_hosts) = @_; | |||
| 6661 | 261 | 269 | my $rules_ref = $service->{rules}; | ||||
| 6662 | 261 | 255 | my $user = $service->{user}; | ||||
| 6663 | 261 | 232 | my $context = $service->{name}; | ||||
| 6664 | 261 | 237 | my $disabled = $service->{disabled}; | ||||
| 6665 | 261 | 235 | my $private = $service->{private}; | ||||
| 6666 | 261 | 591 | my $foreach = $service->{foreach}; | ||||
| 6667 | |||||||
| 6668 | 261 | 291 | for my $unexpanded (@$rules_ref) { | ||||
| 6669 | 298 | 381 | my $deny = $unexpanded->{action} eq 'deny'; | ||||
| 6670 | 298 | 271 | my $log = $unexpanded->{log}; | ||||
| 6671 | 298 | 444 | if ($log) { | ||||
| 6672 | 18 | 21 | check_log($log, $context); | ||||
| 6673 | 18 | 34 | if (@$log) { | ||||
| 6674 | 17 | 21 | $log = normalize_log($log); | ||||
| 6675 | } | ||||||
| 6676 | else { | ||||||
| 6677 | 1 | 1 | $log = undef; | ||||
| 6678 | } | ||||||
| 6679 | } | ||||||
| 6680 | 298 | 658 | my $prt_list = split_protocols(expand_protocols($unexpanded->{prt}, | ||||
| 6681 | "rule in $context")); | ||||||
| 6682 | 298 | 556 | for my $element ($foreach ? @$user : $user) { | ||||
| 6683 | 298 | 318 | $user_object->{elements} = $element; | ||||
| 6684 | 298 | 704 | my $src = expand_group_in_rule($unexpanded->{src}, | ||||
| 6685 | "src of rule in $context", | ||||||
| 6686 | $convert_hosts); | ||||||
| 6687 | 298 | 461 | my $dst_context = "dst of rule in $context"; | ||||
| 6688 | 298 | 778 | my $dst = expand_group_in_rule($unexpanded->{dst}, | ||||
| 6689 | $dst_context, | ||||||
| 6690 | $convert_hosts); | ||||||
| 6691 | 298 | 463 | $dst = add_managed_hosts($dst, $dst_context); | ||||
| 6692 | 298 | 323 | for my $prt (@$prt_list) { | ||||
| 6693 | |||||||
| 6694 | # Prevent modification of original array. | ||||||
| 6695 | 313 | 275 | my $prt = $prt; | ||||
| 6696 | |||||||
| 6697 | # If $prt is duplicate of an identical protocol, | ||||||
| 6698 | # use the main protocol, but remember the original | ||||||
| 6699 | # one for debugging / comments. | ||||||
| 6700 | 313 | 595 | my $orig_prt; | ||||
| 6701 | my $src_range; | ||||||
| 6702 | 313 | 802 | if (ref $prt eq 'ARRAY') { | ||||
| 6703 | 23 | 39 | ($src_range, $prt, $orig_prt) = @$prt; | ||||
| 6704 | } | ||||||
| 6705 | elsif (my $main_prt = $prt->{main}) { | ||||||
| 6706 | 34 | 27 | $orig_prt = $prt; | ||||
| 6707 | 34 | 35 | $prt = $main_prt; | ||||
| 6708 | } | ||||||
| 6709 | |||||||
| 6710 | 313 | 468 | my $flags = $orig_prt ? $orig_prt->{flags} : $prt->{flags}; | ||||
| 6711 | 313 | 313 | my $stateless = $flags->{stateless}; | ||||
| 6712 | 313 | 487 | my ($src, $dst) = | ||||
| 6713 | $flags->{reversed} ? ($dst, $src) : ($src, $dst); | ||||||
| 6714 | |||||||
| 6715 | 313 | 347 | for my $src (@$src) { | ||||
| 6716 | 409 | 1062 | my $src_zone = $obj2zone{$src} || get_zone $src; | ||||
| 6717 | 409 | 406 | my $src_zone_cluster = $src_zone->{zone_cluster}; | ||||
| 6718 | 409 | 452 | for my $dst (@$dst) { | ||||
| 6719 | 502 | 1102 | my $dst_zone = $obj2zone{$dst} || get_zone $dst; | ||||
| 6720 | 502 | 477 | my $dst_zone_cluster = $dst_zone->{zone_cluster}; | ||||
| 6721 | 502 | 1600 | if ( $src_zone eq $dst_zone | ||||
| 6722 | || $src_zone_cluster | ||||||
| 6723 | && $dst_zone_cluster | ||||||
| 6724 | && $src_zone_cluster eq $dst_zone_cluster) | ||||||
| 6725 | { | ||||||
| 6726 | 23 | 36 | collect_unenforceable( | ||||
| 6727 | $src, $dst, $src_zone, $service); | ||||||
| 6728 | 23 | 65 | next; | ||||
| 6729 | } | ||||||
| 6730 | |||||||
| 6731 | # At least one rule is enforceable. | ||||||
| 6732 | # This is used to decide, if a service is fully | ||||||
| 6733 | # unenforceable. | ||||||
| 6734 | 479 | 531 | $service->{seen_enforceable} = 1; | ||||
| 6735 | |||||||
| 6736 | 479 | 1044 | my @src = | ||||
| 6737 | expand_special($src, $dst, $flags->{src}, $context) | ||||||
| 6738 | or next; # Prevent multiple error messages. | ||||||
| 6739 | 479 | 2325 | my @dst = | ||||
| 6740 | expand_special($dst, $src, $flags->{dst}, $context); | ||||||
| 6741 | 479 | 634 | for my $src (@src) { | ||||
| 6742 | 479 | 456 | for my $dst (@dst) { | ||||
| 6743 | 492 | 579 | if ($private) { | ||||
| 6744 | 0 | 0 | my $src_p = $src->{private}; | ||||
| 6745 | 0 | 0 | my $dst_p = $dst->{private}; | ||||
| 6746 | 0 | 0 | $src_p and $src_p eq $private | ||||
| 6747 | or $dst_p and $dst_p eq $private | ||||||
| 6748 | or err_msg | ||||||
| 6749 | "Rule of $private.private $context", | ||||||
| 6750 | " must reference at least one object", | ||||||
| 6751 | " out of $private.private"; | ||||||
| 6752 | } | ||||||
| 6753 | else { | ||||||
| 6754 | 492 | 751 | $src->{private} | ||||
| 6755 | and err_msg | ||||||
| 6756 | "Rule of public $context must not", | ||||||
| 6757 | " reference $src->{name} of", | ||||||
| 6758 | " $src->{private}.private"; | ||||||
| 6759 | 492 | 750 | $dst->{private} | ||||
| 6760 | and err_msg | ||||||
| 6761 | "Rule of public $context must not", | ||||||
| 6762 | " reference $dst->{name} of", | ||||||
| 6763 | " $dst->{private}.private"; | ||||||
| 6764 | } | ||||||
| 6765 | 492 | 646 | next if $disabled; | ||||
| 6766 | |||||||
| 6767 | 492 | 1041 | my $rule = { | ||||
| 6768 | src => $src, | ||||||
| 6769 | dst => $dst, | ||||||
| 6770 | prt => $prt, | ||||||
| 6771 | rule => $unexpanded | ||||||
| 6772 | }; | ||||||
| 6773 | 492 | 669 | $rule->{stateless} = 1 if $stateless; | ||||
| 6774 | 492 | 660 | $rule->{deny} = 1 if $deny; | ||||
| 6775 | 492 | 637 | $rule->{src_range} = $src_range if $src_range; | ||||
| 6776 | 492 | 988 | $rule->{log} = $log if $log; | ||||
| 6777 | 492 | 666 | $rule->{orig_prt} = $orig_prt if $orig_prt; | ||||
| 6778 | 492 | 1036 | $rule->{oneway} = 1 if $flags->{oneway}; | ||||
| 6779 | 492 | 645 | $rule->{no_check_supernet_rules} = 1 | ||||
| 6780 | if $flags->{no_check_supernet_rules}; | ||||||
| 6781 | 492 | 668 | $rule->{stateless_icmp} = 1 | ||||
| 6782 | if $flags->{stateless_icmp}; | ||||||
| 6783 | |||||||
| 6784 | 492 | 2516 | push @$result, $rule; | ||||
| 6785 | } | ||||||
| 6786 | } | ||||||
| 6787 | } | ||||||
| 6788 | } | ||||||
| 6789 | } | ||||||
| 6790 | } | ||||||
| 6791 | } | ||||||
| 6792 | 261 | 420 | show_unenforceable($service); | ||||
| 6793 | |||||||
| 6794 | # Result is returned indirectly using parameter $result. | ||||||
| 6795 | 261 | 508 | return; | ||||
| 6796 | } | ||||||
| 6797 | |||||||
| 6798 | sub print_rulecount { | ||||||
| 6799 | 302 | 0 | 260 | my $count = 0; | |||
| 6800 | 302 | 674 | for my $type ('deny', 'supernet', 'permit') { | ||||
| 6801 | 906 834 906 | 1023 1305 1266 | $count += grep { not $_->{deleted} } @{ $expanded_rules{$type} }; | ||||
| 6802 | } | ||||||
| 6803 | 302 | 651 | info("Expanded rule count: $count"); | ||||
| 6804 | 302 | 284 | return; | ||||
| 6805 | } | ||||||
| 6806 | |||||||
| 6807 | sub split_expanded_rule_types { | ||||||
| 6808 | 315 | 0 | 296 | my ($rules_aref) = @_; | |||
| 6809 | |||||||
| 6810 | 315 | 241 | my (@deny, @permit, @supernet); | ||||
| 6811 | |||||||
| 6812 | 315 | 380 | for my $rule (@$rules_aref) { | ||||
| 6813 | 492 | 1713 | if ($rule->{deny}) { | ||||
| 6814 | 2 | 3 | push @deny, $rule; | ||||
| 6815 | } | ||||||
| 6816 | elsif ($rule->{src}->{is_supernet} || $rule->{dst}->{is_supernet}) { | ||||||
| 6817 | 125 | 188 | push @supernet, $rule; | ||||
| 6818 | } | ||||||
| 6819 | else { | ||||||
| 6820 | 365 | 494 | push @permit, $rule; | ||||
| 6821 | } | ||||||
| 6822 | } | ||||||
| 6823 | |||||||
| 6824 | 315 | 1274 | %expanded_rules = (deny => \@deny, | ||||
| 6825 | permit => \@permit, | ||||||
| 6826 | supernet => \@supernet); | ||||||
| 6827 | 315 | 442 | return; | ||||
| 6828 | } | ||||||
| 6829 | |||||||
| 6830 | sub expand_services { | ||||||
| 6831 | 315 | 0 | 328 | my ($convert_hosts) = @_; | |||
| 6832 | 315 | 693 | convert_hosts if $convert_hosts; | ||||
| 6833 | 315 | 404 | progress('Expanding services'); | ||||
| 6834 | |||||||
| 6835 | 315 | 449 | collect_log(); | ||||
| 6836 | 315 | 354 | my $expanded_rules_aref = []; | ||||
| 6837 | |||||||
| 6838 | # Sort by service name to make output deterministic. | ||||||
| 6839 | 315 | 647 | for my $key (sort keys %services) { | ||||
| 6840 | 261 | 337 | my $service = $services{$key}; | ||||
| 6841 | 261 | 290 | my $name = $service->{name}; | ||||
| 6842 | |||||||
| 6843 | # Substitute service name by service object. | ||||||
| 6844 | 261 | 460 | if (my $overlaps = $service->{overlaps}) { | ||||
| 6845 | 4 | 8 | my @pobjects; | ||||
| 6846 | 4 | 6 | for my $pair (@$overlaps) { | ||||
| 6847 | 4 | 6 | my ($type, $oname) = @$pair; | ||||
| 6848 | 4 | 15 | if (! $type eq 'service') { | ||||
| 6849 | 0 | 0 | err_msg "Unexpected type '$type' in attribute 'overlaps'", | ||||
| 6850 | " of $name"; | ||||||
| 6851 | } | ||||||
| 6852 | elsif (my $other = $services{$oname}) { | ||||||
| 6853 | 4 | 12 | push(@pobjects, $other); | ||||
| 6854 | } | ||||||
| 6855 | else { | ||||||
| 6856 | 0 | 0 | warn_msg("Unknown $type:$oname in attribute 'overlaps'", | ||||
| 6857 | " of $name"); | ||||||
| 6858 | } | ||||||
| 6859 | } | ||||||
| 6860 | 4 | 7 | $service->{overlaps} = \@pobjects; | ||||
| 6861 | } | ||||||
| 6862 | |||||||
| 6863 | # Attribute "visible" is known to have value "*" or "name*". | ||||||
| 6864 | # It must match prefix of some owner name. | ||||||
| 6865 | # Change value to regex to simplify tests: # name* -> /^name.*$/ | ||||||
| 6866 | 261 | 443 | if (my $visible = $service->{visible}) { | ||||
| 6867 | 0 | 0 | if (my ($prefix) = ($visible =~ /^ (\S*) [*] $/x)) { | ||||
| 6868 | 0 | 0 | if ($prefix) { | ||||
| 6869 | 0 0 | 0 0 | if (not grep { /^$prefix/ } keys %owners) { | ||||
| 6870 | 0 | 0 | warn_msg("Attribute 'visible' of $name doesn't match", | ||||
| 6871 | " any owner"); | ||||||
| 6872 | } | ||||||
| 6873 | } | ||||||
| 6874 | 0 | 0 | $service->{visible} = qr/^$prefix.*$/; | ||||
| 6875 | } | ||||||
| 6876 | } | ||||||
| 6877 | |||||||
| 6878 | # Don't convert hosts in user objects here. | ||||||
| 6879 | # This will be done when expanding 'user' inside a rule. | ||||||
| 6880 | 261 | 596 | $service->{user} = expand_group($service->{user}, "user of $name"); | ||||
| 6881 | 261 | 638 | expand_rules($service, $expanded_rules_aref, $convert_hosts); | ||||
| 6882 | } | ||||||
| 6883 | |||||||
| 6884 | 315 | 484 | warn_useless_unenforceable(); | ||||
| 6885 | 315 | 487 | info("Expanded rule count: ", scalar @$expanded_rules_aref); | ||||
| 6886 | |||||||
| 6887 | 315 | 392 | progress('Preparing optimization'); | ||||
| 6888 | 315 | 754 | add_rules($expanded_rules_aref); | ||||
| 6889 | 492 | 873 | info("Expanded rule count: ", | ||||
| 6890 | 315 | 413 | scalar grep { !$_->{deleted} } @$expanded_rules_aref); | ||||
| 6891 | 315 | 432 | show_deleted_rules1(); | ||||
| 6892 | |||||||
| 6893 | # Set attribute {is_supernet} before calling split_expanded_rule_types. | ||||||
| 6894 | 315 | 399 | find_subnets_in_nat_domain(); | ||||
| 6895 | 315 | 444 | split_expanded_rule_types($expanded_rules_aref); | ||||
| 6896 | 315 | 349 | return; | ||||
| 6897 | } | ||||||
| 6898 | |||||||
| 6899 | # For each device, find the IP address which is used | ||||||
| 6900 | # to manage the device from a central policy distribution point. | ||||||
| 6901 | # This address is added as a comment line to each generated code file. | ||||||
| 6902 | # This is to be used later when approving the generated code file. | ||||||
| 6903 | sub set_policy_distribution_ip { | ||||||
| 6904 | 226 | 0 | 294 | progress('Setting policy distribution IP'); | |||
| 6905 | |||||||
| 6906 | # Find all TCP ranges which include port 22 and 23. | ||||||
| 6907 | 429 | 1014 | my @admin_tcp_keys = grep({ | ||||
| 6908 | 226 | 469 | my ($p1, $p2) = split(':', $_); | ||||
| 6909 | 429 | 2062 | $p1 <= 22 && 22 <= $p2 || $p1 <= 23 && 23 <= $p2; | ||||
| 6910 | } | ||||||
| 6911 | 226 | 197 | keys %{ $prt_hash{tcp} }); | ||||
| 6912 | 226 226 | 274 408 | my @prt_list = (@{ $prt_hash{tcp} }{@admin_tcp_keys}, $prt_hash{ip}); | ||||
| 6913 | |||||||
| 6914 | # Mapping from policy distribution host to subnets, networks and | ||||||
| 6915 | # aggregates that include this host. | ||||||
| 6916 | 226 | 183 | my %host2pdp_src; | ||||
| 6917 | my $get_pdp_src = sub { | ||||||
| 6918 | 10 | 9 | my ($host) = @_; | ||||
| 6919 | 10 | 8 | my $pdp_src; | ||||
| 6920 | 10 | 27 | if ($pdp_src = $host2pdp_src{$host}) { | ||||
| 6921 | 1 | 1 | return $pdp_src; | ||||
| 6922 | } | ||||||
| 6923 | 9 9 9 | 9 17 12 | for my $pdp (map { $_ } @{ $host->{subnets} }) { | ||||
| 6924 | 9 | 16 | while ($pdp) { | ||||
| 6925 | 18 | 24 | push @$pdp_src, $pdp; | ||||
| 6926 | 18 | 35 | $pdp = $pdp->{up}; | ||||
| 6927 | } | ||||||
| 6928 | } | ||||||
| 6929 | 9 | 22 | return $host2pdp_src{$host} = $pdp_src; | ||||
| 6930 | 226 | 645 | }; | ||||
| 6931 | 226 | 331 | for my $router (@managed_routers, @routing_only_routers) { | ||||
| 6932 | 365 | 789 | my $pdp = $router->{policy_distribution_point} or next; | ||||
| 6933 | 10 | 20 | next if $router->{orig_router}; | ||||
| 6934 | |||||||
| 6935 | 10 | 12 | my %found_interfaces; | ||||
| 6936 | 10 | 16 | my $no_nat_set = $pdp->{network}->{nat_domain}->{no_nat_set}; | ||||
| 6937 | 10 | 18 | my $pdp_src = $get_pdp_src->($pdp); | ||||
| 6938 | 10 | 12 | my $stateless = ''; | ||||
| 6939 | 10 | 9 | my $deny = ''; | ||||
| 6940 | 10 | 11 | my $src_range = $prt_ip; | ||||
| 6941 | 10 | 12 | for my $src (@$pdp_src) { | ||||
| 6942 | 20 | 63 | my $sub_rule_tree = | ||||
| 6943 | $rule_tree{$stateless}->{$deny}->{$src_range}->{$src} or next; | ||||||
| 6944 | |||||||
| 6945 | # Find interfaces where some rule permits management traffic. | ||||||
| 6946 | 8 8 | 7 14 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 6947 | |||||||
| 6948 | # Loadbalancer VIP can't be used to access device. | ||||||
| 6949 | 18 | 30 | next if $interface->{vip}; | ||||
| 6950 | |||||||
| 6951 | 18 | 20 | for my $prt (@prt_list) { | ||||
| 6952 | 54 | 136 | $sub_rule_tree->{$interface}->{$prt} or next; | ||||
| 6953 | 9 | 24 | $found_interfaces{$interface} = $interface; | ||||
| 6954 | } | ||||||
| 6955 | } | ||||||
| 6956 | } | ||||||
| 6957 | 10 | 11 | my @result; | ||||
| 6958 | |||||||
| 6959 | # Ready, if exactly one management interface was found. | ||||||
| 6960 | 10 | 27 | if (keys %found_interfaces == 1) { | ||||
| 6961 | 7 | 10 | @result = values %found_interfaces; | ||||
| 6962 | } | ||||||
| 6963 | else { | ||||||
| 6964 | |||||||
| 6965 | # debug("$router->{name}: ", scalar keys %found_interfaces); | ||||||
| 6966 | 3 | 5 | my @front = path_auto_interfaces($router, $pdp); | ||||
| 6967 | |||||||
| 6968 | # If multiple management interfaces were found, take that which is | ||||||
| 6969 | # directed to policy_distribution_point. | ||||||
| 6970 | 3 | 5 | for my $front (@front) { | ||||
| 6971 | 4 | 11 | if ($found_interfaces{$front}) { | ||||
| 6972 | 2 | 2 | push @result, $front; | ||||
| 6973 | } | ||||||
| 6974 | } | ||||||
| 6975 | |||||||
| 6976 | # Take all management interfaces. | ||||||
| 6977 | # Preserve original order of router interfaces. | ||||||
| 6978 | 3 | 6 | if (! @result) { | ||||
| 6979 | 2 4 2 | 2 10 3 | @result = grep { $found_interfaces{$_} } @{ $router->{interfaces} }; | ||||
| 6980 | } | ||||||
| 6981 | |||||||
| 6982 | # Don't set {admin_ip} if no address is found. | ||||||
| 6983 | # Warning is printed below. | ||||||
| 6984 | 3 | 9 | next if not @result; | ||||
| 6985 | } | ||||||
| 6986 | |||||||
| 6987 | # Prefer loopback interface if available. | ||||||
| 6988 | 9 | 23 | $router->{admin_ip} = [ | ||||
| 6989 | 1 | 8 | map { print_ip((address($_, $no_nat_set))->[0]) } | ||||
| 6990 | 8 | 14 | sort { ($b->{loopback} || '') cmp($a->{loopback} || '') } @result | ||||
| 6991 | ]; | ||||||
| 6992 | } | ||||||
| 6993 | 226 | 241 | my %seen; | ||||
| 6994 | my @unreachable; | ||||||
| 6995 | 226 | 268 | for my $router (@managed_routers, @routing_only_routers) { | ||||
| 6996 | 365 | 655 | next if $seen{$router}; | ||||
| 6997 | 364 | 693 | next if !$router->{policy_distribution_point}; | ||||
| 6998 | 9 | 18 | next if $router->{orig_router}; | ||||
| 6999 | 9 | 16 | if (my $vrf_members = $router->{vrf_members}) { | ||||
| 7000 | 1 | 2 | for my $member (@$vrf_members) { | ||||
| 7001 | 1 | 5 | if (!$member->{admin_ip}) { | ||||
| 7002 | 1 | 3 | push(@unreachable, | ||||
| 7003 | "some VRF of router:$router->{device_name}"); | ||||||
| 7004 | 1 | 1 | last; | ||||
| 7005 | } | ||||||
| 7006 | } | ||||||
| 7007 | |||||||
| 7008 | # Print VRF instance with known admin_ip first. | ||||||
| 7009 | 1 | 5 | $router->{vrf_members} = [ | ||||
| 7010 | sort { | ||||||
| 7011 | 1 | 2 | !$a->{admin_ip} <=> !$b->{admin_ip} | ||||
| 7012 | || $a->{name} cmp $b->{name} | ||||||
| 7013 | } @$vrf_members | ||||||
| 7014 | ]; | ||||||
| 7015 | 1 | 4 | $seen{$_} = 1 for @$vrf_members; | ||||
| 7016 | } | ||||||
| 7017 | else { | ||||||
| 7018 | 8 | 15 | $router->{admin_ip} | ||||
| 7019 | or push @unreachable, $router->{name}; | ||||||
| 7020 | 8 | 22 | $seen{$router} = 1; | ||||
| 7021 | } | ||||||
| 7022 | } | ||||||
| 7023 | 226 | 381 | if (@unreachable) { | ||||
| 7024 | 1 | 2 | if (@unreachable > 4) { | ||||
| 7025 | 0 | 0 | splice(@unreachable, 3, @unreachable - 3, '...'); | ||||
| 7026 | } | ||||||
| 7027 | 1 | 3 | my $list = join("\n - ", @unreachable); | ||||
| 7028 | 1 | 2 | warn_msg ( | ||||
| 7029 | "Missing rules to reach devices from policy_distribution_point:\n", | ||||||
| 7030 | " - ", $list); | ||||||
| 7031 | } | ||||||
| 7032 | 226 | 983 | return; | ||||
| 7033 | } | ||||||
| 7034 | |||||||
| 7035 | ############################################################################## | ||||||
| 7036 | # Distribute owner, identify service owner | ||||||
| 7037 | ############################################################################## | ||||||
| 7038 | |||||||
| 7039 | sub propagate_owners { | ||||||
| 7040 | 311 | 0 | 274 | my %zone_got_net_owners; | |||
| 7041 | my %clusters; | ||||||
| 7042 | ZONE: | ||||||
| 7043 | 311 | 327 | for my $zone (@zones) { | ||||
| 7044 | 824 | 1242 | if (my $cluster = $zone->{zone_cluster}) { | ||||
| 7045 | 44 | 73 | $clusters{$cluster} = $cluster; | ||||
| 7046 | } | ||||||
| 7047 | |||||||
| 7048 | # If an explicit owner was set, it has been set for | ||||||
| 7049 | # the whole cluster in link_aggregates. | ||||||
| 7050 | 824 | 1449 | next if $zone->{owner}; | ||||
| 7051 | |||||||
| 7052 | # Inversed inheritance: If a zone has no direct owner and if | ||||||
| 7053 | # all contained real toplevel networks have the same owner, | ||||||
| 7054 | # then set owner of this zone to the one owner. | ||||||
| 7055 | 815 | 577 | my $owner; | ||||
| 7056 | 815 815 | 595 927 | for my $network (@{ $zone->{networks} }) { | ||||
| 7057 | 807 | 1206 | next if $network->{ip} eq 'tunnel'; | ||||
| 7058 | 807 | 655 | my $net_owner = $network->{owner}; | ||||
| 7059 | 807 | 1599 | next ZONE if not $net_owner; | ||||
| 7060 | 10 | 16 | if ($owner) { | ||||
| 7061 | 1 | 3 | next ZONE if $net_owner ne $owner; | ||||
| 7062 | } | ||||||
| 7063 | else { | ||||||
| 7064 | 9 | 14 | $owner = $net_owner; | ||||
| 7065 | } | ||||||
| 7066 | } | ||||||
| 7067 | 17 | 37 | if ($owner) { | ||||
| 7068 | # debug("Inversed inherit: $zone->{name} $owner->{name}"); | ||||||
| 7069 | 8 | 8 | $zone->{owner} = $owner; | ||||
| 7070 | 8 | 17 | $zone_got_net_owners{$zone} = 1; | ||||
| 7071 | } | ||||||
| 7072 | } | ||||||
| 7073 | |||||||
| 7074 | # Check for consistent implicit owners of zone clusters. | ||||||
| 7075 | # Implicit owner from networks is only valid, if the same owner | ||||||
| 7076 | # is found for all zones of cluster. | ||||||
| 7077 | 311 | 528 | for my $cluster (values %clusters) { | ||||
| 7078 | 18 44 | 23 97 | my @implicit_owner_zones = grep { $zone_got_net_owners{$_} } @$cluster | ||||
| 7079 | or next; | ||||||
| 7080 | 0 | 0 | if ( | ||||
| 7081 | !( | ||||||
| 7082 | 0 | 0 | @implicit_owner_zones == @$cluster | ||||
| 7083 | && equal(map { $_->{owner} } @implicit_owner_zones) | ||||||
| 7084 | ) | ||||||
| 7085 | ) | ||||||
| 7086 | { | ||||||
| 7087 | 0 | 0 | $_->{owner} = undef for @implicit_owner_zones; | ||||
| 7088 | |||||||
| 7089 | # debug("Reset owner"); | ||||||
| 7090 | # debug($_->{name}) for @implicit_owner_zones; | ||||||
| 7091 | } | ||||||
| 7092 | } | ||||||
| 7093 | |||||||
| 7094 | # A zone can be part of multiple areas. | ||||||
| 7095 | # Find the smallest enclosing area. | ||||||
| 7096 | 311 | 267 | my %zone2area; | ||||
| 7097 | 311 | 337 | for my $zone (@zones) { | ||||
| 7098 | 824 824 | 606 2228 | my @areas = values %{ $zone->{areas} } or next; | ||||
| 7099 | 82 32 32 32 | 92 27 33 40 | @areas = sort { @{ $a->{zones} } <=> @{ $b->{zones} } } @areas; | ||||
| 7100 | 82 | 162 | $zone2area{$zone} = $areas[0]; | ||||
| 7101 | } | ||||||
| 7102 | |||||||
| 7103 | # Build tree from inheritance relation: | ||||||
| 7104 | # area -> [area|zone, ..] | ||||||
| 7105 | # zone -> [network, ..] | ||||||
| 7106 | # network -> [network, ..] | ||||||
| 7107 | # network -> [host|interface, ..] | ||||||
| 7108 | 311 | 307 | my %tree; | ||||
| 7109 | my %is_child; | ||||||
| 7110 | 0 | 0 | my %ref2obj; | ||||
| 7111 | my $add_node = sub { | ||||||
| 7112 | 1697 | 1503 | my ($super, $sub) = @_; | ||||
| 7113 | 1697 1697 | 1189 3132 | push @{ $tree{$super} }, $sub; | ||||
| 7114 | 1697 | 2517 | $is_child{$sub} = 1; | ||||
| 7115 | 1697 | 2138 | $ref2obj{$sub} = $sub; | ||||
| 7116 | 1697 | 2923 | $ref2obj{$super} = $super; | ||||
| 7117 | 311 | 988 | }; | ||||
| 7118 | |||||||
| 7119 | # Find subset relation between areas. | ||||||
| 7120 | 311 | 404 | for my $area (@areas) { | ||||
| 7121 | 59 | 133 | if (my $super = $area->{subset_of}) { | ||||
| 7122 | 16 | 27 | $add_node->($super, $area); | ||||
| 7123 | } | ||||||
| 7124 | } | ||||||
| 7125 | |||||||
| 7126 | # Find direct subset relation between areas and zones. | ||||||
| 7127 | 311 | 352 | for my $area (@areas) { | ||||
| 7128 | 59 59 | 56 77 | for my $zone (@{ $area->{zones} }) { | ||||
| 7129 | 110 | 258 | if ($zone2area{$zone} eq $area) { | ||||
| 7130 | 82 | 101 | $add_node->($area, $zone); | ||||
| 7131 | } | ||||||
| 7132 | } | ||||||
| 7133 | } | ||||||
| 7134 | |||||||
| 7135 | # Find subset relation between networks and hosts/interfaces. | ||||||
| 7136 | my $add_hosts = sub { | ||||||
| 7137 | 1007 | 789 | my ($network) = @_; | ||||
| 7138 | 1007 1007 | 716 1362 | for my $host (@{ $network->{hosts} }) { | ||||
| 7139 | 149 | 173 | $add_node->($network, $host); | ||||
| 7140 | } | ||||||
| 7141 | 1007 1007 | 818 1120 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 7142 | 1454 | 1233 | my $router = $interface->{router}; | ||||
| 7143 | 1454 | 3724 | if (!($router->{managed} || $router->{routing_only})) { | ||||
| 7144 | 443 | 550 | $add_node->($network, $interface); | ||||
| 7145 | } | ||||||
| 7146 | } | ||||||
| 7147 | 311 | 791 | }; | ||||
| 7148 | |||||||
| 7149 | # Find subset relation between networks and networks. | ||||||
| 7150 | 311 | 272 | my $add_subnets; | ||||
| 7151 | $add_subnets = sub { | ||||||
| 7152 | 1007 | 818 | my ($network) = @_; | ||||
| 7153 | 1007 | 1087 | $add_hosts->($network); | ||||
| 7154 | 1007 | 2637 | my $subnets = $network->{networks} or return; | ||||
| 7155 | 50 | 76 | for my $subnet (@$subnets) { | ||||
| 7156 | 52 | 59 | $add_node->($network, $subnet); | ||||
| 7157 | 52 | 118 | $add_subnets->($subnet); | ||||
| 7158 | } | ||||||
| 7159 | 311 | 726 | }; | ||||
| 7160 | |||||||
| 7161 | # Find subset relation between zones and networks. | ||||||
| 7162 | 311 | 344 | for my $zone (@zones) { | ||||
| 7163 | 824 824 | 636 964 | for my $network (@{ $zone->{networks} }) { | ||||
| 7164 | 955 | 1114 | $add_node->($zone, $network); | ||||
| 7165 | 955 | 1077 | $add_subnets->($network); | ||||
| 7166 | } | ||||||
| 7167 | } | ||||||
| 7168 | |||||||
| 7169 | # Find root nodes. | ||||||
| 7170 | 775 | 1321 | my @root_nodes = | ||||
| 7171 | 311 1330 | 722 1785 | sort by_name map { $ref2obj{$_} } grep { not $is_child{$_} } keys %tree; | ||||
| 7172 | |||||||
| 7173 | # owner is extended by e_owner at node. | ||||||
| 7174 | # owner->[[node, e_owner, .. ], .. ] | ||||||
| 7175 | 311 | 377 | my %extended; | ||||
| 7176 | |||||||
| 7177 | # upper_owner: owner object without attribute extend_only or undef | ||||||
| 7178 | # extend: a list of owners with attribute extend | ||||||
| 7179 | # extend_only: a list of owners with attribute extend_only | ||||||
| 7180 | my $inherit; | ||||||
| 7181 | $inherit = sub { | ||||||
| 7182 | 2472 | 2410 | my ($node, $upper_owner, $upper_node, $extend, $extend_only) = @_; | ||||
| 7183 | 2472 | 2112 | my $owner = $node->{owner}; | ||||
| 7184 | 2472 | 2643 | if (!$owner) { | ||||
| 7185 | 2406 | 2539 | $node->{owner} = $upper_owner; | ||||
| 7186 | } | ||||||
| 7187 | else { | ||||||
| 7188 | 66 | 66 | $owner->{is_used} = 1; | ||||
| 7189 | 66 | 102 | if ($upper_owner) { | ||||
| 7190 | 36 | 69 | if ($owner eq $upper_owner) { | ||||
| 7191 | 13 | 26 | if (! $zone_got_net_owners{$upper_node}) | ||||
| 7192 | { | ||||||
| 7193 | 5 | 23 | warn_msg("Useless $owner->{name} at $node->{name},\n", | ||||
| 7194 | " it was already inherited from", | ||||||
| 7195 | " $upper_node->{name}"); | ||||||
| 7196 | } | ||||||
| 7197 | } | ||||||
| 7198 | else { | ||||||
| 7199 | 23 | 43 | if ($upper_owner->{extend}) { | ||||
| 7200 | 3 | 5 | $extend = [ $upper_owner, @$extend ]; | ||||
| 7201 | } | ||||||
| 7202 | } | ||||||
| 7203 | } | ||||||
| 7204 | 66 | 78 | my @extend_list = ($node); | ||||
| 7205 | 66 | 99 | push @extend_list, @$extend if $extend; | ||||
| 7206 | 66 | 94 | push @extend_list, @$extend_only if $extend_only; | ||||
| 7207 | 66 66 | 48 138 | push @{ $extended{$owner} }, \@extend_list; | ||||
| 7208 | } | ||||||
| 7209 | 2472 | 3908 | if (!$owner || !$owner->{extend_only}) { | ||||
| 7210 | 2466 | 3514 | if (my $upper_extend = $extend_only->[0]) { | ||||
| 7211 | 20 | 22 | $node->{extended_owner} = $upper_extend; | ||||
| 7212 | } | ||||||
| 7213 | } | ||||||
| 7214 | |||||||
| 7215 | 2472 | 5197 | if ($owner && $owner->{extend_only}) { | ||||
| 7216 | 6 | 7 | $extend_only = [ $owner, @$extend_only ]; | ||||
| 7217 | 6 | 6 | $upper_owner = undef; | ||||
| 7218 | 6 | 6 | $upper_node = undef; | ||||
| 7219 | } | ||||||
| 7220 | elsif($owner) { | ||||||
| 7221 | 60 | 47 | $upper_owner = $owner; | ||||
| 7222 | 60 | 53 | $upper_node = $node; | ||||
| 7223 | } | ||||||
| 7224 | 2472 | 6684 | my $childs = $tree{$node} or return; | ||||
| 7225 | 1330 | 1318 | for my $child (@$childs) { | ||||
| 7226 | 1697 | 3042 | $inherit->($child, $upper_owner, $upper_node, $extend, | ||||
| 7227 | $extend_only); | ||||||
| 7228 | } | ||||||
| 7229 | 311 | 1277 | }; | ||||
| 7230 | 311 | 379 | for my $node (@root_nodes) { | ||||
| 7231 | 775 | 1219 | $inherit->($node, undef, undef, [], []); | ||||
| 7232 | } | ||||||
| 7233 | |||||||
| 7234 | # Collect extended owners and check for inconsistent extensions. | ||||||
| 7235 | # Check owner with attribute {show_all}. | ||||||
| 7236 | 311 | 783 | for my $owner (sort by_name values %owners) { | ||||
| 7237 | 48 | 108 | my $aref = $extended{$owner} || []; | ||||
| 7238 | 48 | 44 | my $node1; | ||||
| 7239 | my $ext1; | ||||||
| 7240 | 0 | 0 | my $combined; | ||||
| 7241 | 48 | 51 | for my $node_ext (@$aref) { | ||||
| 7242 | 66 | 65 | my $node = shift @$node_ext; | ||||
| 7243 | 66 | 118 | next if $zone_got_net_owners{$node}; | ||||
| 7244 | 58 | 46 | my $ext = $node_ext; | ||||
| 7245 | 58 | 74 | if ($node1) { | ||||
| 7246 | 14 | 19 | for my $owner_list ($ext1, $ext) { | ||||
| 7247 | 28 | 60 | my ($other, $owner_node, $other_node) = | ||||
| 7248 | $owner_list eq $ext | ||||||
| 7249 | ? ($ext1, $node, $node1) | ||||||
| 7250 | : ($ext, $node1, $node); | ||||||
| 7251 | 28 | 46 | for my $e_owner (@$owner_list) { | ||||
| 7252 | 6 | 13 | next if $e_owner->{extend_unbounded}; | ||||
| 7253 | 5 6 | 5 15 | next if grep { $e_owner eq $_ } @$other; | ||||
| 7254 | 5 | 23 | warn_msg("$owner->{name}", | ||||
| 7255 | " is extended by $e_owner->{name}\n", | ||||||
| 7256 | " - only at $owner_node->{name}\n", | ||||||
| 7257 | " - but not at $other_node->{name}"); | ||||||
| 7258 | } | ||||||
| 7259 | } | ||||||
| 7260 | 14 | 30 | $combined = [ @$ext, @$combined ]; | ||||
| 7261 | } | ||||||
| 7262 | else { | ||||||
| 7263 | 44 | 33 | $combined = $ext; | ||||
| 7264 | 44 | 75 | ($node1, $ext1) = ($node, $ext); | ||||
| 7265 | } | ||||||
| 7266 | } | ||||||
| 7267 | 48 | 155 | if ($combined && @$combined) { | ||||
| 7268 | 10 | 15 | $owner->{extended_by} = [ unique @$combined ]; | ||||
| 7269 | } | ||||||
| 7270 | 48 | 117 | if ($owner->{show_all}) { | ||||
| 7271 | 1 | 1 | my @invalid; | ||||
| 7272 | 1 | 1 | for my $node (@root_nodes) { | ||||
| 7273 | 3 | 9 | my $node_owner = $node->{owner} || ''; | ||||
| 7274 | 3 | 6 | if ($node_owner ne $owner) { | ||||
| 7275 | 2 | 2 | push @invalid, $node; | ||||
| 7276 | } | ||||||
| 7277 | } | ||||||
| 7278 | 1 | 2 | if (@invalid) { | ||||
| 7279 | 1 2 | 2 4 | my $missing = join("\n - ", map { $_->{name} } @invalid); | ||||
| 7280 | 1 | 4 | err_msg("$owner->{name} has attribute 'show_all',", | ||||
| 7281 | " but doesn't own whole topology.\n", | ||||||
| 7282 | " Missing:\n", | ||||||
| 7283 | " - $missing"); | ||||||
| 7284 | } | ||||||
| 7285 | } | ||||||
| 7286 | } | ||||||
| 7287 | |||||||
| 7288 | # Handle {router_attributes}->{owner} separately. | ||||||
| 7289 | # Areas can be nested. Proceed from small to larger ones. | ||||||
| 7290 | 311 28 28 28 | 523 26 30 41 | for my $area (sort { @{ $a->{zones} } <=> @{ $b->{zones} } } @areas) { | ||||
| 7291 | 59 | 127 | my $attributes = $area->{router_attributes} or next; | ||||
| 7292 | 7 | 17 | my $owner = $attributes->{owner} or next; | ||||
| 7293 | 0 | 0 | $owner->{is_used} = 1; | ||||
| 7294 | 0 0 | 0 0 | for my $router (@{ $area->{managed_routers} }) { | ||||
| 7295 | 0 | 0 | if (my $r_owner = $router->{owner}) { | ||||
| 7296 | 0 | 0 | if ($r_owner eq $owner) { | ||||
| 7297 | 0 | 0 | warn_msg( | ||||
| 7298 | "Useless $r_owner->{name} at $router->{name},\n", | ||||||
| 7299 | " it was already inherited from $attributes->{name}"); | ||||||
| 7300 | } | ||||||
| 7301 | } | ||||||
| 7302 | else { | ||||||
| 7303 | 0 | 0 | $router->{owner} = $owner; | ||||
| 7304 | } | ||||||
| 7305 | } | ||||||
| 7306 | } | ||||||
| 7307 | |||||||
| 7308 | 311 | 400 | for my $router (@managed_routers, @routing_only_routers) { | ||||
| 7309 | 454 | 897 | my $owner = $router->{owner} or next; | ||||
| 7310 | 1 | 2 | $owner->{is_used} = 1; | ||||
| 7311 | |||||||
| 7312 | 1 | 2 | for my $interface (get_intf($router)) { | ||||
| 7313 | |||||||
| 7314 | # Loadbalancer interface with {vip} can have dedicated owner. | ||||||
| 7315 | 3 | 9 | $interface->{owner} ||= $owner; | ||||
| 7316 | } | ||||||
| 7317 | } | ||||||
| 7318 | |||||||
| 7319 | # Propagate owner of loopback interface to loopback network | ||||||
| 7320 | # and loopback zone. | ||||||
| 7321 | 311 | 369 | for my $router (@routers) { | ||||
| 7322 | 634 | 1245 | my $managed = $router->{managed} || $router->{routing_only}; | ||||
| 7323 | 634 634 | 470 757 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 7324 | 1498 | 2664 | $interface->{loopback} or next; | ||||
| 7325 | 39 | 82 | my $owner = $interface->{owner} or next; | ||||
| 7326 | 1 | 1 | my $network = $interface->{network}; | ||||
| 7327 | 1 | 2 | $network->{owner} = $owner; | ||||
| 7328 | 1 | 2 | $network->{zone}->{owner} = $owner if $managed; | ||||
| 7329 | |||||||
| 7330 | # Mark dedicated owner of {vip} interface, which is also a | ||||||
| 7331 | # loopback interface. | ||||||
| 7332 | 1 | 2 | $owner->{is_used} = 1; | ||||
| 7333 | } | ||||||
| 7334 | } | ||||||
| 7335 | |||||||
| 7336 | # Inherit owner from enclosing network or zone to aggregate. | ||||||
| 7337 | 311 | 341 | for my $zone (@zones) { | ||||
| 7338 | 824 824 | 617 1536 | for my $aggregate (values %{ $zone->{ipmask2aggregate} }) { | ||||
| 7339 | 49 | 96 | next if $aggregate->{owner}; | ||||
| 7340 | 49 | 41 | my $up = $aggregate; | ||||
| 7341 | 49 | 100 | while ($up = $up->{up}) { | ||||
| 7342 | 17 | 31 | last if !$up->{is_aggregate}; | ||||
| 7343 | } | ||||||
| 7344 | 49 | 123 | $aggregate->{owner} = ($up ? $up : $zone)->{owner}; | ||||
| 7345 | } | ||||||
| 7346 | } | ||||||
| 7347 | 311 | 748 | return; | ||||
| 7348 | } | ||||||
| 7349 | |||||||
| 7350 | sub expand_auto_intf { | ||||||
| 7351 | 514 | 0 | 474 | my ($src_aref, $dst_aref) = @_; | |||
| 7352 | 514 | 861 | for (my $i = 0 ; $i < @$src_aref ; $i++) { | ||||
| 7353 | 703 | 586 | my $src = $src_aref->[$i]; | ||||
| 7354 | 703 | 774 | next if not is_autointerface($src); | ||||
| 7355 | 23 | 21 | my @new; | ||||
| 7356 | 23 | 27 | for my $dst (@$dst_aref) { | ||||
| 7357 | 26 | 40 | push @new, path_auto_interfaces($src, $dst); | ||||
| 7358 | } | ||||||
| 7359 | |||||||
| 7360 | # Substitute auto interface by real interface(s). | ||||||
| 7361 | # Possible duplicate elements in @new are removed later. | ||||||
| 7362 | 23 | 67 | splice(@$src_aref, $i, 1, @new); | ||||
| 7363 | } | ||||||
| 7364 | 514 | 520 | return; | ||||
| 7365 | } | ||||||
| 7366 | |||||||
| 7367 | my %unknown2services; | ||||||
| 7368 | my %unknown2unknown; | ||||||
| 7369 | |||||||
| 7370 | sub show_unknown_owners { | ||||||
| 7371 | 311 | 0 | 495 | for my $polices (values %unknown2services) { | |||
| 7372 | 0 | 0 | $polices = join(',', sort @$polices); | ||||
| 7373 | } | ||||||
| 7374 | 311 | 667 | my $print = | ||||
| 7375 | $config{check_service_unknown_owner} eq 'warn' | ||||||
| 7376 | ? \&warn_msg | ||||||
| 7377 | : \&err_msg; | ||||||
| 7378 | UNKNOWN: | ||||||
| 7379 | 311 | 492 | for my $obj (values %unknown2unknown) { | ||||
| 7380 | 0 | 0 | my $up = $obj; | ||||
| 7381 | 0 | 0 | while ($up = $up->{up}) { | ||||
| 7382 | 0 | 0 | if ( $unknown2services{$up} | ||||
| 7383 | and $unknown2services{$obj} eq $unknown2services{$up}) | ||||||
| 7384 | { | ||||||
| 7385 | 0 | 0 | next UNKNOWN; | ||||
| 7386 | } | ||||||
| 7387 | } | ||||||
| 7388 | 0 | 0 | $print->("Unknown owner for $obj->{name} in $unknown2services{$obj}"); | ||||
| 7389 | } | ||||||
| 7390 | 311 | 476 | %unknown2services = %unknown2unknown = (); | ||||
| 7391 | 311 | 299 | return; | ||||
| 7392 | } | ||||||
| 7393 | |||||||
| 7394 | sub set_service_owner { | ||||||
| 7395 | 311 | 0 | 390 | progress('Checking service owner'); | |||
| 7396 | |||||||
| 7397 | 311 | 419 | propagate_owners(); | ||||
| 7398 | |||||||
| 7399 | 311 | 627 | for my $key (sort keys %services) { | ||||
| 7400 | 257 | 378 | my $service = $services{$key}; | ||||
| 7401 | 257 | 270 | my $sname = $service->{name}; | ||||
| 7402 | |||||||
| 7403 | 257 | 647 | my $users = expand_group($service->{user}, "user of $sname"); | ||||
| 7404 | |||||||
| 7405 | # Non 'user' objects. | ||||||
| 7406 | 257 | 241 | my @objects; | ||||
| 7407 | |||||||
| 7408 | # Check, if service contains a coupling rule with only "user" elements. | ||||||
| 7409 | 257 | 223 | my $is_coupling = 0; | ||||
| 7410 | |||||||
| 7411 | 257 257 | 221 362 | for my $rule (@{ $service->{rules} }) { | ||||
| 7412 | 291 | 302 | my $has_user = $rule->{has_user}; | ||||
| 7413 | 291 | 462 | if ($has_user eq 'both') { | ||||
| 7414 | 11 | 12 | $is_coupling = 1; | ||||
| 7415 | 11 | 19 | next; | ||||
| 7416 | } | ||||||
| 7417 | 280 | 287 | for my $what (qw(src dst)) { | ||||
| 7418 | 560 | 902 | next if $what eq $has_user; | ||||
| 7419 | 280 | 648 | push(@objects, | ||||
| 7420 | 280 | 219 | @{ expand_group($rule->{$what}, "$what of $sname") }); | ||||
| 7421 | } | ||||||
| 7422 | } | ||||||
| 7423 | |||||||
| 7424 | # Expand auto interface of objects in rules to set of real interfaces. | ||||||
| 7425 | 257 | 432 | expand_auto_intf(\@objects, $users); | ||||
| 7426 | |||||||
| 7427 | # Expand auto interfaces in users with counterpart in | ||||||
| 7428 | # - users and objects | ||||||
| 7429 | # - only users | ||||||
| 7430 | # - only objects. | ||||||
| 7431 | # Add elements of expanded users to objects. | ||||||
| 7432 | 257 | 363 | if ($is_coupling) { | ||||
| 7433 | 11 | 21 | if (@objects) { | ||||
| 7434 | 0 | 0 | expand_auto_intf($users, [ @objects, @$users ]); | ||||
| 7435 | } | ||||||
| 7436 | else { | ||||||
| 7437 | 11 | 19 | expand_auto_intf($users, $users); | ||||
| 7438 | } | ||||||
| 7439 | 11 | 14 | push @objects, @$users; | ||||
| 7440 | } | ||||||
| 7441 | else { | ||||||
| 7442 | 246 | 311 | expand_auto_intf($users, \@objects); | ||||
| 7443 | } | ||||||
| 7444 | |||||||
| 7445 | # Collect service owners and unknown owners; | ||||||
| 7446 | 257 | 232 | my $service_owners; | ||||
| 7447 | my $unknown_owners; | ||||||
| 7448 | |||||||
| 7449 | 257 | 368 | for my $obj (unique @objects) { | ||||
| 7450 | 307 | 319 | my $owner = $obj->{owner}; | ||||
| 7451 | 307 | 741 | if ($owner) { | ||||
| 7452 | 15 | 35 | $service_owners->{$owner} = $owner; | ||||
| 7453 | } | ||||||
| 7454 | else { | ||||||
| 7455 | 292 | 657 | $unknown_owners->{$obj} = $obj; | ||||
| 7456 | } | ||||||
| 7457 | } | ||||||
| 7458 | |||||||
| 7459 | 257 | 547 | $service->{owners} = [ values %$service_owners ]; | ||||
| 7460 | |||||||
| 7461 | # Check for redundant service owner. | ||||||
| 7462 | # Allow dedicated service owner, if we have multiple owners | ||||||
| 7463 | # from @objects. | ||||||
| 7464 | 257 | 474 | if (my $sub_owner = $service->{sub_owner}) { | ||||
| 7465 | 1 | 1 | $sub_owner->{is_used} = 1; | ||||
| 7466 | 1 | 3 | (keys %$service_owners == 1 && $service_owners->{$sub_owner}) and | ||||
| 7467 | warn_msg("Useless $sub_owner->{name} at $service->{name}"); | ||||||
| 7468 | } | ||||||
| 7469 | |||||||
| 7470 | # Check for multiple owners. | ||||||
| 7471 | 257 | 397 | my $multi_count = | ||||
| 7472 | $is_coupling | ||||||
| 7473 | ? 1 | ||||||
| 7474 | : values %$service_owners; | ||||||
| 7475 | 257 | 924 | if ($multi_count > 1 xor $service->{multi_owner}) { | ||||
| 7476 | 1 | 3 | if ($service->{multi_owner}) { | ||||
| 7477 | 0 | 0 | warn_msg("Useless use of attribute 'multi_owner' at $sname"); | ||||
| 7478 | } | ||||||
| 7479 | else { | ||||||
| 7480 | my $print = | ||||||
| 7481 | $config{check_service_multi_owner} | ||||||
| 7482 | ? $config{check_service_multi_owner} eq 'warn' | ||||||
| 7483 | ? \&warn_msg | ||||||
| 7484 | : \&err_msg | ||||||
| 7485 | 1 0 | 4 0 | : sub { }; | ||||
| 7486 | 2 | 10 | my @names = | ||||
| 7487 | 1 | 2 | sort(map { ($_->{name} =~ /^owner:(.*)/)[0] } | ||||
| 7488 | values %$service_owners); | ||||||
| 7489 | 1 | 5 | $print->("$sname has multiple owners:\n " . join(', ', @names)); | ||||
| 7490 | } | ||||||
| 7491 | } | ||||||
| 7492 | |||||||
| 7493 | # Check for unknown owners. | ||||||
| 7494 | 257 | 1353 | if (($unknown_owners and keys %$unknown_owners) | ||||
| 7495 | xor $service->{unknown_owner}) | ||||||
| 7496 | { | ||||||
| 7497 | 246 | 319 | if ($service->{unknown_owner}) { | ||||
| 7498 | 0 | 0 | warn_msg("Useless use of attribute 'unknown_owner' at $sname"); | ||||
| 7499 | } | ||||||
| 7500 | else { | ||||||
| 7501 | 246 | 1044 | if ($config{check_service_unknown_owner}) { | ||||
| 7502 | 0 | 0 | for my $obj (values %$unknown_owners) { | ||||
| 7503 | 0 | 0 | $unknown2unknown{$obj} = $obj; | ||||
| 7504 | 0 0 | 0 0 | push @{ $unknown2services{$obj} }, $sname; | ||||
| 7505 | } | ||||||
| 7506 | } | ||||||
| 7507 | } | ||||||
| 7508 | } | ||||||
| 7509 | } | ||||||
| 7510 | |||||||
| 7511 | # Show unused owners. | ||||||
| 7512 | # Remove attribute {is_used}, which isn't needed any longer. | ||||||
| 7513 | 311 | 557 | for my $owner (values %owners) { | ||||
| 7514 | 48 | 108 | delete $owner->{is_used} or warn_msg("Unused $owner->{name}"); | ||||
| 7515 | } | ||||||
| 7516 | |||||||
| 7517 | 311 | 450 | show_unknown_owners(); | ||||
| 7518 | 311 | 260 | return; | ||||
| 7519 | } | ||||||
| 7520 | |||||||
| 7521 | ############################################################################## | ||||||
| 7522 | # Distribute NAT bindings | ||||||
| 7523 | ############################################################################## | ||||||
| 7524 | |||||||
| 7525 | # NAT Set: a set of NAT tags which are effective at some location. | ||||||
| 7526 | # NAT Domain: a maximal area of the topology (a set of connected networks) | ||||||
| 7527 | # where the NAT set is identical at each network. | ||||||
| 7528 | sub set_natdomain; | ||||||
| 7529 | |||||||
| 7530 | sub set_natdomain { | ||||||
| 7531 | 1243 | 0 | 1173 | my ($network, $domain, $in_interface) = @_; | |||
| 7532 | |||||||
| 7533 | # Found a loop inside a NAT domain. | ||||||
| 7534 | 1243 | 2013 | return if $network->{nat_domain}; | ||||
| 7535 | |||||||
| 7536 | # debug("$domain->{name}: $network->{name}"); | ||||||
| 7537 | 1112 | 1511 | $network->{nat_domain} = $domain; | ||||
| 7538 | 1112 1112 | 835 1379 | push @{ $domain->{networks} }, $network; | ||||
| 7539 | 1112 1112 | 931 1343 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 7540 | |||||||
| 7541 | # Ignore interface where we reached this network. | ||||||
| 7542 | 1630 | 3394 | next if $interface eq $in_interface; | ||||
| 7543 | |||||||
| 7544 | 961 | 1399 | next if $interface->{main_interface}; | ||||
| 7545 | |||||||
| 7546 | # debug("IN $interface->{name}"); | ||||||
| 7547 | 883 | 630 | my $err_seen; | ||||
| 7548 | 883 | 2112 | my $nat_tags = $interface->{bind_nat} || $bind_nat0; | ||||
| 7549 | 883 | 757 | my $router = $interface->{router}; | ||||
| 7550 | 883 883 | 657 1077 | for my $out_interface (@{ $router->{interfaces} }) { | ||||
| 7551 | |||||||
| 7552 | # Don't process interface where we reached this router. | ||||||
| 7553 | 2128 | 4217 | next if $out_interface eq $interface; | ||||
| 7554 | |||||||
| 7555 | # Current NAT domain continues behind $out_interface. | ||||||
| 7556 | 1245 | 2827 | my $out_nat_tags = $out_interface->{bind_nat} || $bind_nat0; | ||||
| 7557 | 1245 | 1487 | if (aref_eq($out_nat_tags, $nat_tags)) { | ||||
| 7558 | |||||||
| 7559 | # Put check for active path inside this loop, because | ||||||
| 7560 | # 1. we must enter each router from each side to detect | ||||||
| 7561 | # all inconsistencies, | ||||||
| 7562 | # 2. we need the check at all to prevent deep recursion. | ||||||
| 7563 | # | ||||||
| 7564 | # 'local' declaration restores previous value on block exit. | ||||||
| 7565 | 965 | 1426 | next if $router->{active_path}; | ||||
| 7566 | 905 | 1109 | local $router->{active_path} = 1; | ||||
| 7567 | |||||||
| 7568 | 905 | 1377 | next if $out_interface->{main_interface}; | ||||
| 7569 | |||||||
| 7570 | 800 | 705 | my $next_net = $out_interface->{network}; | ||||
| 7571 | 800 | 1322 | set_natdomain($next_net, $domain, $out_interface); | ||||
| 7572 | } | ||||||
| 7573 | |||||||
| 7574 | # New NAT domain starts at some interface of current router. | ||||||
| 7575 | # Remember NAT tag of current domain. | ||||||
| 7576 | else { | ||||||
| 7577 | |||||||
| 7578 | # If one router is connected to the same NAT domain | ||||||
| 7579 | # by different interfaces, all interfaces must have | ||||||
| 7580 | # the same NAT binding. (This occurs only in loops). | ||||||
| 7581 | 280 | 604 | if (my $old_nat_tags = $router->{nat_tags}->{$domain}) { | ||||
| 7582 | 79 | 87 | if (not aref_eq($old_nat_tags, $nat_tags)) { | ||||
| 7583 | 1 | 5 | next if $err_seen->{$old_nat_tags}->{$nat_tags}++; | ||||
| 7584 | 1 | 4 | my $old_names = join(',', @$old_nat_tags) || '(none)'; | ||||
| 7585 | 1 | 5 | my $new_names = join(',', @$nat_tags) || '(none)'; | ||||
| 7586 | 1 | 5 | err_msg | ||||
| 7587 | "Inconsistent NAT in loop at $router->{name}:\n", | ||||||
| 7588 | " nat:$old_names vs. nat:$new_names"; | ||||||
| 7589 | } | ||||||
| 7590 | |||||||
| 7591 | # NAT domain and router have been linked together already. | ||||||
| 7592 | 79 | 141 | next; | ||||
| 7593 | } | ||||||
| 7594 | 201 | 347 | $router->{nat_tags}->{$domain} = $nat_tags; | ||||
| 7595 | # debug("OUT $out_interface->{name}"); | ||||||
| 7596 | 201 201 | 152 233 | push @{ $domain->{routers} }, $router; | ||||
| 7597 | 201 201 | 173 442 | push @{ $router->{nat_domains} }, $domain; | ||||
| 7598 | } | ||||||
| 7599 | } | ||||||
| 7600 | } | ||||||
| 7601 | 1112 | 2185 | return; | ||||
| 7602 | } | ||||||
| 7603 | |||||||
| 7604 | my @natdomains; | ||||||
| 7605 | |||||||
| 7606 | # Distribute NAT tags from NAT domain to NAT domain. | ||||||
| 7607 | # Returns | ||||||
| 7608 | # - undef on success | ||||||
| 7609 | # - aref of routers, if invalid path was found in loop. | ||||||
| 7610 | sub distribute_nat1 { | ||||||
| 7611 | 119 | 0 | 129 | my ($domain, $nat_tag, $nat_tags2multi, $in_router) = @_; | |||
| 7612 | |||||||
| 7613 | # debug "nat:$nat_tag at $domain->{name} from $in_router->{name}"; | ||||||
| 7614 | 119 | 196 | if ($domain->{active_path}) { | ||||
| 7615 | |||||||
| 7616 | # debug("$domain->{name} loop"); | ||||||
| 7617 | # Found a loop | ||||||
| 7618 | 1 | 6 | return; | ||||
| 7619 | } | ||||||
| 7620 | |||||||
| 7621 | # Tag is already there. | ||||||
| 7622 | 118 | 108 | my $nat_set = $domain->{nat_set}; | ||||
| 7623 | 118 | 198 | return if $nat_set->{$nat_tag}; | ||||
| 7624 | |||||||
| 7625 | # Must not enter one NAT domain at different routers with | ||||||
| 7626 | # different elements of grouped NAT tags. | ||||||
| 7627 | 104 | 194 | if (my $aref = $nat_tags2multi->{$nat_tag}) { | ||||
| 7628 | 42 | 41 | for my $multi_href (@$aref) { | ||||
| 7629 | 51 | 107 | for my $nat_tag2 (sort keys %$multi_href) { | ||||
| 7630 | 119 | 236 | if ($nat_set->{$nat_tag2}) { | ||||
| 7631 | 2 | 9 | err_msg("Grouped NAT tags '$nat_tag2' and '$nat_tag'", | ||||
| 7632 | " must not both be active inside $domain->{name}"); | ||||||
| 7633 | } | ||||||
| 7634 | } | ||||||
| 7635 | } | ||||||
| 7636 | } | ||||||
| 7637 | |||||||
| 7638 | # Add tag. | ||||||
| 7639 | # Use a hash to prevent duplicate entries. | ||||||
| 7640 | 104 | 152 | $nat_set->{$nat_tag} = 1; | ||||
| 7641 | |||||||
| 7642 | # Network which has translation with tag $nat_tag must not be located | ||||||
| 7643 | # in area where this tag is effective. | ||||||
| 7644 | 104 104 | 89 147 | for my $network (@{ $domain->{networks} }) { | ||||
| 7645 | 133 | 280 | my $nat = $network->{nat} or next; | ||||
| 7646 | 6 | 13 | $nat->{$nat_tag} or next; | ||||
| 7647 | 1 | 8 | err_msg("$network->{name} is translated by $nat_tag,\n", | ||||
| 7648 | " but is located inside the translation domain of $nat_tag.\n", | ||||||
| 7649 | " Probably $nat_tag was bound to wrong interface", | ||||||
| 7650 | " at $in_router->{name}."); | ||||||
| 7651 | |||||||
| 7652 | # Show error message only once. | ||||||
| 7653 | 1 | 2 | last; | ||||
| 7654 | } | ||||||
| 7655 | |||||||
| 7656 | # Activate loop detection. | ||||||
| 7657 | 104 | 162 | local $in_router->{active_path} = 1; | ||||
| 7658 | 104 | 124 | local $domain->{active_path} = 1; | ||||
| 7659 | |||||||
| 7660 | # Distribute NAT tag to adjacent NAT domains. | ||||||
| 7661 | 104 104 | 91 127 | for my $router (@{ $domain->{routers} }) { | ||||
| 7662 | 136 | 321 | next if $router eq $in_router; | ||||
| 7663 | 33 | 37 | my $in_nat_tags = $router->{nat_tags}->{$domain}; | ||||
| 7664 | |||||||
| 7665 | # Found another interface with same NAT binding. | ||||||
| 7666 | # This stops effect of current NAT tag. | ||||||
| 7667 | 33 14 | 50 42 | next if grep { $_ eq $nat_tag } @$in_nat_tags; | ||||
| 7668 | |||||||
| 7669 | # Traverse loop twice to prevent inherited errors. | ||||||
| 7670 | # Check for recursive and duplicate NAT. | ||||||
| 7671 | 23 23 | 20 30 | for my $out_domain (@{ $router->{nat_domains} }) { | ||||
| 7672 | 51 | 85 | next if $out_domain eq $domain; | ||||
| 7673 | 29 | 40 | my $out_nat_tags = $router->{nat_tags}->{$out_domain}; | ||||
| 7674 | |||||||
| 7675 | # Must not apply one NAT tag multiple times in a row. | ||||||
| 7676 | 29 25 | 32 70 | if (grep { $_ eq $nat_tag } @$out_nat_tags) { | ||||
| 7677 | |||||||
| 7678 | # Check for recursive NAT in loop. | ||||||
| 7679 | 3 | 6 | if ($router->{active_path}) { | ||||
| 7680 | |||||||
| 7681 | # Abort traversal and start collecting path. | ||||||
| 7682 | 1 | 5 | return [ $router ]; | ||||
| 7683 | } | ||||||
| 7684 | 2 | 9 | err_msg("nat:$nat_tag is applied twice between", | ||||
| 7685 | " $in_router->{name} and $router->{name}"); | ||||||
| 7686 | } | ||||||
| 7687 | } | ||||||
| 7688 | |||||||
| 7689 | DOMAIN: | ||||||
| 7690 | 22 22 | 19 28 | for my $out_domain (@{ $router->{nat_domains} }) { | ||||
| 7691 | 49 | 86 | next if $out_domain eq $domain; | ||||
| 7692 | 27 | 31 | my $out_nat_tags = $router->{nat_tags}->{$out_domain}; | ||||
| 7693 | |||||||
| 7694 | # Effect of current NAT tag stops if another element of | ||||||
| 7695 | # grouped NAT tags becomes active. | ||||||
| 7696 | 27 | 52 | if (my $aref = $nat_tags2multi->{$nat_tag}) { | ||||
| 7697 | 21 | 21 | for my $href (@$aref) { | ||||
| 7698 | 22 | 25 | for my $nat_tag2 (@$out_nat_tags) { | ||||
| 7699 | 20 | 26 | next if $nat_tag2 eq $nat_tag; | ||||
| 7700 | 20 | 39 | next if !$href->{$nat_tag2}; | ||||
| 7701 | |||||||
| 7702 | # debug "- $nat_tag2"; | ||||||
| 7703 | # Prevent transition from dynamic to | ||||||
| 7704 | # static NAT. | ||||||
| 7705 | 16 | 14 | my $nat_info = $href->{$nat_tag}; | ||||
| 7706 | 16 | 16 | my $next_info = $href->{$nat_tag2}; | ||||
| 7707 | |||||||
| 7708 | # Use $next_info->{name} and not $nat_info->{name} | ||||||
| 7709 | # because $nat_info may show wrong network, | ||||||
| 7710 | # because we combined different hidden networks into | ||||||
| 7711 | # $nat_tags2multi. | ||||||
| 7712 | 16 | 27 | if ($nat_info->{hidden}) { | ||||
| 7713 | 3 | 14 | err_msg("Must not change hidden nat:$nat_tag", | ||||
| 7714 | " using nat:$nat_tag2\n", | ||||||
| 7715 | " for $next_info->{name}", | ||||||
| 7716 | " at $router->{name}"); | ||||||
| 7717 | } | ||||||
| 7718 | elsif ($nat_info->{dynamic}) { | ||||||
| 7719 | 0 | 0 | if(!($next_info->{dynamic})) { | ||||
| 7720 | 0 | 0 | err_msg("Must not change dynamic nat:$nat_tag", | ||||
| 7721 | " to static using nat:$nat_tag2\n", | ||||||
| 7722 | " for $nat_info->{name}", | ||||||
| 7723 | " at $router->{name}"); | ||||||
| 7724 | } | ||||||
| 7725 | } | ||||||
| 7726 | 16 | 46 | next DOMAIN; | ||||
| 7727 | } | ||||||
| 7728 | } | ||||||
| 7729 | } | ||||||
| 7730 | |||||||
| 7731 | # debug "Caller $domain->{name}"; | ||||||
| 7732 | 11 | 29 | if (my $err_path = distribute_nat1($out_domain, $nat_tag, | ||||
| 7733 | $nat_tags2multi, $router)) | ||||||
| 7734 | { | ||||||
| 7735 | 1 | 1 | push @$err_path, $router; | ||||
| 7736 | 1 | 4 | return $err_path; | ||||
| 7737 | } | ||||||
| 7738 | } | ||||||
| 7739 | } | ||||||
| 7740 | 102 | 286 | return; | ||||
| 7741 | } | ||||||
| 7742 | |||||||
| 7743 | sub distribute_nat { | ||||||
| 7744 | 108 | 0 | 137 | my ($domain, $nat_tag, $nat_tags2multi, $in_router) = @_; | |||
| 7745 | 108 | 138 | if (my $err_path = distribute_nat1($domain, $nat_tag, | ||||
| 7746 | $nat_tags2multi, $in_router)) { | ||||||
| 7747 | 1 | 1 | push @$err_path, $in_router; | ||||
| 7748 | 3 | 6 | err_msg("nat:$nat_tag is applied recursively in loop at this path:\n", | ||||
| 7749 | 1 | 4 | " - ", join("\n - ", map { $_->{name} } reverse @$err_path)); | ||||
| 7750 | } | ||||||
| 7751 | 108 | 108 | return; | ||||
| 7752 | } | ||||||
| 7753 | |||||||
| 7754 | sub distribute_nat_info { | ||||||
| 7755 | 332 | 0 | 474 | progress('Distributing NAT'); | |||
| 7756 | |||||||
| 7757 | # Mapping from nat_tag to boolean. Is false if all NAT mappings map | ||||||
| 7758 | # to hidden. | ||||||
| 7759 | 332 | 269 | my %has_non_hidden; | ||||
| 7760 | |||||||
| 7761 | 332 | 366 | for my $network (@networks) { | ||||
| 7762 | 1165 | 1978 | my $href = $network->{nat} or next; | ||||
| 7763 | 109 | 178 | for my $nat_tag (keys %$href) { | ||||
| 7764 | 128 | 131 | my $nat_network = $href->{$nat_tag}; | ||||
| 7765 | 128 | 219 | if (!$nat_network->{hidden}) { | ||||
| 7766 | 91 | 192 | $has_non_hidden{$nat_tag} = 1; | ||||
| 7767 | } | ||||||
| 7768 | } | ||||||
| 7769 | } | ||||||
| 7770 | |||||||
| 7771 | # A hash with all defined NAT tags. | ||||||
| 7772 | # It is used to check, | ||||||
| 7773 | # - if all NAT definitions are bound and | ||||||
| 7774 | # - if all bound NAT tags are defined somewhere. | ||||||
| 7775 | 332 | 336 | my %nat_definitions; | ||||
| 7776 | |||||||
| 7777 | # Check consistency of grouped NAT tags at one network. | ||||||
| 7778 | # If NAT tags are grouped at one network, | ||||||
| 7779 | # the same NAT tags must be used as group at all other networks. | ||||||
| 7780 | # Suppose tags A and B are used grouped. | ||||||
| 7781 | # An occurence of bind_nat = A activates NAT:A. | ||||||
| 7782 | # An successive bind_nat = B actives NAT:B, but implicitly disables NAT:A. | ||||||
| 7783 | # Hence A is disabled for all networks and therefore | ||||||
| 7784 | # this restriction is needed. | ||||||
| 7785 | # Exception: | ||||||
| 7786 | # NAT tags with "hidden" can be added to some valid set of grouped tags, | ||||||
| 7787 | # because we don't allow transition from hidden tag back to some other | ||||||
| 7788 | # (hidden) tag. | ||||||
| 7789 | # | ||||||
| 7790 | # A hash with all defined NAT tags as keys and aref of hrefs as value. | ||||||
| 7791 | # The href has those NAT tags as keys which are used together at one | ||||||
| 7792 | # network. | ||||||
| 7793 | # This is used to check, | ||||||
| 7794 | # that NAT tags are equally used grouped or solitary. | ||||||
| 7795 | my %nat_tags2multi; | ||||||
| 7796 | 0 | 0 | my %all_hidden; | ||||
| 7797 | 332 | 345 | for my $network (@networks) { | ||||
| 7798 | 1165 | 1908 | my $href = $network->{nat} or next; | ||||
| 7799 | # debug $network->{name}, " href=", join(',', sort keys %$href); | ||||||
| 7800 | |||||||
| 7801 | # Print error message only once per network. | ||||||
| 7802 | 109 | 80 | my $err_shown; | ||||
| 7803 | my $show_err = sub { | ||||||
| 7804 | 5 | 6 | my ($href1, $href2) = @_; | ||||
| 7805 | 5 | 8 | return if $err_shown; | ||||
| 7806 | 3 | 7 | my $tags1 = join(',', sort keys %$href1); | ||||
| 7807 | 3 | 5 | my $name1 = $network->{name}; | ||||
| 7808 | 3 | 8 | my $tags2 = join(',', sort keys %$href2); | ||||
| 7809 | |||||||
| 7810 | # Values are NAT entries with name of network. | ||||||
| 7811 | # Take first value deterministically. | ||||||
| 7812 | 3 7 | 5 11 | my ($name2) = sort map { $_->{name} } values %$href2; | ||||
| 7813 | 3 | 15 | err_msg | ||||
| 7814 | "If multiple NAT tags are used at one network,\n", | ||||||
| 7815 | " these NAT tags must be used", | ||||||
| 7816 | " equally grouped at other networks:\n", | ||||||
| 7817 | " - $name1: $tags1\n", | ||||||
| 7818 | " - $name2: $tags2"; | ||||||
| 7819 | 3 | 4 | $err_shown = 1; | ||||
| 7820 | 3 | 4 | return; | ||||
| 7821 | 109 | 388 | }; | ||||
| 7822 | |||||||
| 7823 | NAT_TAG: | ||||||
| 7824 | 109 | 241 | for my $nat_tag (sort keys %$href) { | ||||
| 7825 | 128 | 160 | $nat_definitions{$nat_tag} = 1; | ||||
| 7826 | 128 | 236 | if (my $aref = $nat_tags2multi{$nat_tag}) { | ||||
| 7827 | |||||||
| 7828 | # If elements have a common non hidden tag, | ||||||
| 7829 | # then only a single href is allowed. | ||||||
| 7830 | 31 | 61 | if ($has_non_hidden{$nat_tag}) { | ||||
| 7831 | 18 | 18 | my $href2 = $aref->[0]; | ||||
| 7832 | 18 | 28 | keys_eq($href, $href2) or $show_err->($href, $href2); | ||||
| 7833 | 18 | 82 | next NAT_TAG; | ||||
| 7834 | } | ||||||
| 7835 | |||||||
| 7836 | # Array of hrefs has common hidden NAT tag. | ||||||
| 7837 | # | ||||||
| 7838 | # Ignore new href if it is identical to some previous one. | ||||||
| 7839 | 13 | 14 | for my $href2 (@$aref) { | ||||
| 7840 | 18 | 20 | keys_eq($href, $href2) and next NAT_TAG; | ||||
| 7841 | } | ||||||
| 7842 | |||||||
| 7843 | # Some element is non hidden, check detailed. | ||||||
| 7844 | 11 56 | 18 76 | if (grep { $has_non_hidden{$_} } %$href) { | ||||
| 7845 | |||||||
| 7846 | # Check new href for consistency with previous hrefs. | ||||||
| 7847 | 8 | 18 | for my $nat_tag2 (sort keys %$href) { | ||||
| 7848 | 22 | 32 | next if $nat_tag2 eq $nat_tag; | ||||
| 7849 | 14 | 20 | for my $href2 (@$aref) { | ||||
| 7850 | |||||||
| 7851 | # Don't check previous href with all hidden tags. | ||||||
| 7852 | 25 | 42 | next if $all_hidden{$href2}; | ||||
| 7853 | |||||||
| 7854 | # Non hidden tag must not occur in other href. | ||||||
| 7855 | 19 | 24 | if ($has_non_hidden{$nat_tag2}) { | ||||
| 7856 | 13 | 29 | if ($href2->{$nat_tag2}) { | ||||
| 7857 | 1 | 3 | $show_err->($href, $href2); | ||||
| 7858 | next NAT_TAG | ||||||
| 7859 | 1 | 2 | } | ||||
| 7860 | } | ||||||
| 7861 | |||||||
| 7862 | # Hidden tag must occur in all other hrefs. | ||||||
| 7863 | else { | ||||||
| 7864 | 6 | 15 | if (!$href2->{$nat_tag2}) { | ||||
| 7865 | 0 | 0 | $show_err->($href, $href2); | ||||
| 7866 | next NAT_TAG | ||||||
| 7867 | 0 | 0 | } | ||||
| 7868 | } | ||||||
| 7869 | } | ||||||
| 7870 | } | ||||||
| 7871 | } | ||||||
| 7872 | |||||||
| 7873 | # All elements are hidden. Always ok. | ||||||
| 7874 | else { | ||||||
| 7875 | |||||||
| 7876 | # Mark this type of href for easier checks. | ||||||
| 7877 | 3 | 5 | $all_hidden{$href} = 1; | ||||
| 7878 | } | ||||||
| 7879 | |||||||
| 7880 | # If current href and some previous href are in subset | ||||||
| 7881 | # relation, then take larger set. | ||||||
| 7882 | 10 | 14 | for my $href2 (@$aref) { | ||||
| 7883 | 14 40 | 19 47 | my $common_size = grep { $href2->{$_ } } keys %$href; | ||||
| 7884 | 14 | 39 | if ($common_size eq keys %$href) { | ||||
| 7885 | |||||||
| 7886 | # Ignore new href, because it is subset. | ||||||
| 7887 | 1 | 6 | next NAT_TAG; | ||||
| 7888 | } | ||||||
| 7889 | elsif ($common_size eq keys %$href2) { | ||||||
| 7890 | |||||||
| 7891 | # Replace previous href by new superset. | ||||||
| 7892 | 0 | 0 | $href2 = $href; | ||||
| 7893 | 0 | 0 | next NAT_TAG; | ||||
| 7894 | } | ||||||
| 7895 | else { | ||||||
| 7896 | |||||||
| 7897 | # Add new href below. | ||||||
| 7898 | } | ||||||
| 7899 | } | ||||||
| 7900 | } | ||||||
| 7901 | 106 106 | 98 555 | push @{ $nat_tags2multi{$nat_tag} }, $href; | ||||
| 7902 | } | ||||||
| 7903 | } | ||||||
| 7904 | |||||||
| 7905 | # Remove single entries. | ||||||
| 7906 | 332 | 578 | for my $nat_tag (keys %nat_tags2multi) { | ||||
| 7907 | 97 | 106 | my $aref = $nat_tags2multi{$nat_tag}; | ||||
| 7908 | 97 | 157 | next if @$aref > 1; | ||||
| 7909 | 91 | 88 | my $href = $aref->[0]; | ||||
| 7910 | 91 | 144 | next if keys %$href > 1; | ||||
| 7911 | 59 | 134 | delete $nat_tags2multi{$nat_tag}; | ||||
| 7912 | } | ||||||
| 7913 | |||||||
| 7914 | # Find NAT domains. | ||||||
| 7915 | 332 | 388 | for my $network (@networks) { | ||||
| 7916 | 1165 | 1696 | next if $network->{is_aggregate}; | ||||
| 7917 | 1112 | 1777 | next if $network->{nat_domain}; | ||||
| 7918 | 443 | 2306 | (my $name = $network->{name}) =~ s/^\w+:/nat_domain:/; | ||||
| 7919 | 443 | 1020 | my $domain = new( | ||||
| 7920 | 'nat_domain', | ||||||
| 7921 | name => $name, | ||||||
| 7922 | networks => [], | ||||||
| 7923 | routers => [], | ||||||
| 7924 | nat_set => {}, | ||||||
| 7925 | ); | ||||||
| 7926 | 443 | 483 | push @natdomains, $domain; | ||||
| 7927 | 443 | 619 | set_natdomain($network, $domain, 0); | ||||
| 7928 | } | ||||||
| 7929 | |||||||
| 7930 | # Distribute NAT tags to NAT domains. | ||||||
| 7931 | 332 | 392 | for my $domain (@natdomains) { | ||||
| 7932 | 443 443 | 348 736 | for my $router (@{ $domain->{routers} }) { | ||||
| 7933 | 201 | 279 | my $nat_tags = $router->{nat_tags}->{$domain}; | ||||
| 7934 | # debug "$domain->{name} $router->{name}: ", join(',', @$nat_tags); | ||||||
| 7935 | |||||||
| 7936 | # Multiple tags are bound to interface. | ||||||
| 7937 | # If some network has multiple matching NAT tags, | ||||||
| 7938 | # the resulting NAT mapping would be ambiguous. | ||||||
| 7939 | 201 | 299 | if (@$nat_tags >= 2) { | ||||
| 7940 | NAT_TAG: | ||||||
| 7941 | 3 | 3 | for my $nat_tag (@$nat_tags) { | ||||
| 7942 | 5 | 9 | my $aref = $nat_tags2multi{$nat_tag} or next; | ||||
| 7943 | 5 | 6 | for my $href (@$aref) { | ||||
| 7944 | 5 10 | 5 27 | my @tags = grep { $href->{$_} && $_ } @$nat_tags; | ||||
| 7945 | 5 | 14 | @tags >= 2 or next; | ||||
| 7946 | 1 | 2 | my $tags = join(',', @tags); | ||||
| 7947 | 1 | 1 | my $nat_net = $href->{$tags[0]}; | ||||
| 7948 | 1 | 5 | err_msg("Must not bind multiple NAT tags", | ||||
| 7949 | " '$tags' of $nat_net->{name}", | ||||||
| 7950 | " at $router->{name}"); | ||||||
| 7951 | |||||||
| 7952 | # Show only first error. Otherwise we | ||||||
| 7953 | # would show the same error multiple | ||||||
| 7954 | # times. | ||||||
| 7955 | 1 | 2 | last NAT_TAG; | ||||
| 7956 | } | ||||||
| 7957 | } | ||||||
| 7958 | } | ||||||
| 7959 | 201 | 300 | for my $nat_tag (@$nat_tags) { | ||||
| 7960 | 109 | 181 | if ($nat_definitions{$nat_tag}) { | ||||
| 7961 | 108 | 195 | distribute_nat($domain, $nat_tag, \%nat_tags2multi, | ||||
| 7962 | $router); | ||||||
| 7963 | 108 | 304 | $nat_definitions{$nat_tag} = 'used'; | ||||
| 7964 | } | ||||||
| 7965 | else { | ||||||
| 7966 | 1 | 4 | warn_msg("Ignoring useless nat:$nat_tag", | ||||
| 7967 | " bound at $router->{name}"); | ||||||
| 7968 | } | ||||||
| 7969 | } | ||||||
| 7970 | } | ||||||
| 7971 | } | ||||||
| 7972 | |||||||
| 7973 | # Check compatibility of host/interface and network NAT. | ||||||
| 7974 | # A NAT definition for a single host/interface is only allowed, | ||||||
| 7975 | # if the network has a dynamic NAT definition. | ||||||
| 7976 | 332 | 377 | for my $network (@networks) { | ||||
| 7977 | 1165 1165 1165 | 859 1174 1315 | for my $obj (@{ $network->{hosts} }, @{ $network->{interfaces} }) { | ||||
| 7978 | 1810 | 3414 | if ($obj->{nat}) { | ||||
| 7979 | 5 5 | 6 10 | for my $nat_tag (keys %{ $obj->{nat} }) { | ||||
| 7980 | 5 | 5 | my $nat_network; | ||||
| 7981 | 5 | 23 | if ( $nat_network = $network->{nat}->{$nat_tag} | ||||
| 7982 | and $nat_network->{dynamic}) | ||||||
| 7983 | { | ||||||
| 7984 | 5 | 8 | my $obj_ip = $obj->{nat}->{$nat_tag}; | ||||
| 7985 | 5 5 | 5 9 | my ($ip, $mask) = @{$nat_network}{ 'ip', 'mask' }; | ||||
| 7986 | 5 | 9 | if (not(match_ip($obj_ip, $ip, $mask))) { | ||||
| 7987 | 0 | 0 | err_msg "nat:$nat_tag: $obj->{name}'s IP ", | ||||
| 7988 | "doesn't match $network->{name}'s IP/mask"; | ||||||
| 7989 | } | ||||||
| 7990 | } | ||||||
| 7991 | else { | ||||||
| 7992 | 0 | 0 | err_msg "nat:$nat_tag not allowed for ", | ||||
| 7993 | "$obj->{name} because $network->{name} ", | ||||||
| 7994 | "doesn't have dynamic NAT definition"; | ||||||
| 7995 | } | ||||||
| 7996 | } | ||||||
| 7997 | } | ||||||
| 7998 | } | ||||||
| 7999 | } | ||||||
| 8000 | |||||||
| 8001 | 332 | 587 | for my $name (keys %nat_definitions) { | ||||
| 8002 | 97 | 225 | $nat_definitions{$name} eq 'used' or | ||||
| 8003 | warn_msg("nat:$name is defined, but not bound to any interface"); | ||||||
| 8004 | } | ||||||
| 8005 | |||||||
| 8006 | # Find interfaces with dynamic NAT which is applied at the same device. | ||||||
| 8007 | # This is incomatible with device with "need_protect". | ||||||
| 8008 | 332 | 393 | for my $network (@networks) { | ||||
| 8009 | 1165 | 1958 | my $nat = $network->{nat} or next; | ||||
| 8010 | 109 | 156 | for my $nat_tag (keys %$nat) { | ||||
| 8011 | 128 | 129 | my $nat_info = $nat->{$nat_tag}; | ||||
| 8012 | 128 | 221 | $nat_info->{dynamic} or next; | ||||
| 8013 | 74 74 | 60 88 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 8014 | 89 | 75 | my $intf_nat = $interface->{nat}; | ||||
| 8015 | |||||||
| 8016 | # Interface has static translation, | ||||||
| 8017 | 89 | 171 | next if $intf_nat && $intf_nat->{$nat_tag}; | ||||
| 8018 | |||||||
| 8019 | 86 | 72 | my $router = $interface->{router}; | ||||
| 8020 | 86 | 237 | next if !$router->{need_protect}; | ||||
| 8021 | 0 0 | 0 0 | for my $bind_intf (@{ $router->{interfaces} }) { | ||||
| 8022 | 0 | 0 | my $bind = $bind_intf->{bind_nat} or next; | ||||
| 8023 | 0 0 | 0 0 | grep { $_ eq $nat_tag } @$bind or next; | ||||
| 8024 | 0 | 0 | err_msg("Must not apply dynamic NAT to $interface->{name}", | ||||
| 8025 | " at $bind_intf->{name} of same device.\n", | ||||||
| 8026 | " This isn't supported for model", | ||||||
| 8027 | " $router->{model}->{name}."); | ||||||
| 8028 | } | ||||||
| 8029 | } | ||||||
| 8030 | } | ||||||
| 8031 | } | ||||||
| 8032 | 332 | 505 | invert_nat_set(); | ||||
| 8033 | 332 | 543 | return; | ||||
| 8034 | } | ||||||
| 8035 | |||||||
| 8036 | sub invert_nat_set { | ||||||
| 8037 | |||||||
| 8038 | # Find NAT partitions. | ||||||
| 8039 | # NAT partitions arise, if parts of the topology are strictly | ||||||
| 8040 | # separated by crypto interfaces. | ||||||
| 8041 | 332 | 0 | 298 | my %partitions; | |||
| 8042 | my $mark_nat_partition; | ||||||
| 8043 | $mark_nat_partition = sub { | ||||||
| 8044 | 679 | 618 | my ($domain, $mark) = @_; | ||||
| 8045 | 679 | 1406 | return if $partitions{$domain}; | ||||
| 8046 | # debug "$mark $domain->{name}"; | ||||||
| 8047 | 443 | 649 | $partitions{$domain} = $mark; | ||||
| 8048 | 443 443 | 368 875 | for my $router (@{ $domain->{routers} }) { | ||||
| 8049 | 201 201 | 155 220 | for my $out_domain (@{ $router->{nat_domains} }) { | ||||
| 8050 | 437 | 1008 | next if $out_domain eq $domain; | ||||
| 8051 | 236 | 428 | $mark_nat_partition->($out_domain, $mark); | ||||
| 8052 | } | ||||||
| 8053 | } | ||||||
| 8054 | 332 | 1117 | }; | ||||
| 8055 | 332 | 347 | my $mark = 0; | ||||
| 8056 | 332 | 361 | for my $domain (@natdomains) { | ||||
| 8057 | 443 | 362 | $mark++; | ||||
| 8058 | 443 | 575 | $mark_nat_partition->($domain, $mark); | ||||
| 8059 | } | ||||||
| 8060 | |||||||
| 8061 | # Collect NAT tags used in each partition. | ||||||
| 8062 | 332 | 294 | my %partition2tags; | ||||
| 8063 | 332 | 359 | for my $domain (@natdomains) { | ||||
| 8064 | 443 | 574 | my $mark = $partitions{$domain}; | ||||
| 8065 | 443 443 | 345 554 | for my $network (@{ $domain->{networks} }) { | ||||
| 8066 | 1112 | 2119 | my $href = $network->{nat} or next; | ||||
| 8067 | 109 | 165 | for my $nat_tag (keys %$href) { | ||||
| 8068 | 128 | 340 | $partition2tags{$mark}->{$nat_tag} = 1; | ||||
| 8069 | } | ||||||
| 8070 | } | ||||||
| 8071 | } | ||||||
| 8072 | |||||||
| 8073 | # Invert {nat_set} to {no_nat_set} | ||||||
| 8074 | 332 | 373 | for my $domain (@natdomains) { | ||||
| 8075 | 443 | 537 | my $nat_set = delete $domain->{nat_set}; | ||||
| 8076 | 443 | 601 | my $mark = $partitions{$domain}; | ||||
| 8077 | 443 | 1221 | my $all_nat_set = $partition2tags{$mark} ||= {}; | ||||
| 8078 | # debug "$mark $domain->{name} all: ", join(',', keys %$all_nat_set); | ||||||
| 8079 | 443 | 774 | my $no_nat_set = { %$all_nat_set }; | ||||
| 8080 | 443 443 | 554 474 | delete @{$no_nat_set}{keys %$nat_set}; | ||||
| 8081 | 443 | 1109 | $domain->{no_nat_set} = $no_nat_set; | ||||
| 8082 | # debug "$mark $domain->{name} no: ", join(',', keys %$no_nat_set); | ||||||
| 8083 | } | ||||||
| 8084 | |||||||
| 8085 | # Distribute {no_nat_set} to interfaces. | ||||||
| 8086 | # no_nat_set is needed at logical and hardware interfaces of | ||||||
| 8087 | # managed routers. Set it also for semi_managed routers to | ||||||
| 8088 | # calculate {up} relation between subnets. | ||||||
| 8089 | 332 | 409 | for my $domain (@natdomains) { | ||||
| 8090 | 443 | 430 | my $no_nat_set = $domain->{no_nat_set}; | ||||
| 8091 | 443 443 | 337 533 | for my $network (@{ $domain->{networks} }) { | ||||
| 8092 | 1112 1112 | 828 1240 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 8093 | 1630 | 1372 | my $router = $interface->{router}; | ||||
| 8094 | 1630 | 3746 | ($router->{managed} || $router->{semi_managed}) or next; | ||||
| 8095 | |||||||
| 8096 | # debug("$domain->{name}: NAT $interface->{name}"); | ||||||
| 8097 | 1158 | 1303 | $interface->{no_nat_set} = $no_nat_set; | ||||
| 8098 | 1158 | 3266 | $interface->{hardware}->{no_nat_set} = $no_nat_set | ||||
| 8099 | if $router->{managed} || $router->{routing_only}; | ||||||
| 8100 | } | ||||||
| 8101 | } | ||||||
| 8102 | } | ||||||
| 8103 | 332 | 644 | return(); | ||||
| 8104 | } | ||||||
| 8105 | |||||||
| 8106 | # Real interface of crypto tunnel has got {no_nat_set} of that NAT domain, | ||||||
| 8107 | # where encrypted traffic passes. But real interface gets ACL that filter | ||||||
| 8108 | # both encrypted and unencrypted traffic. Hence no_nat_set must be extended by | ||||||
| 8109 | # no_nat_set of some corresponding tunnel interface. | ||||||
| 8110 | sub adjust_crypto_nat { | ||||||
| 8111 | 332 | 0 | 296 | my %seen; | |||
| 8112 | 332 | 525 | for my $crypto (values %crypto) { | ||||
| 8113 | 21 21 | 18 29 | for my $tunnel (@{ $crypto->{tunnels} }) { | ||||
| 8114 | 25 | 40 | next if $tunnel->{disabled}; | ||||
| 8115 | 25 25 | 21 31 | for my $tunnel_intf (@{ $tunnel->{interfaces} }) { | ||||
| 8116 | 50 | 43 | my $real_intf = $tunnel_intf->{real_interface}; | ||||
| 8117 | 50 | 117 | next if $seen{$real_intf}++; | ||||
| 8118 | 43 | 79 | $real_intf->{router}->{managed} or next; | ||||
| 8119 | 21 | 23 | my $tunnel_set = $tunnel_intf->{no_nat_set}; | ||||
| 8120 | 21 | 63 | keys %$tunnel_set or next; | ||||
| 8121 | |||||||
| 8122 | # Copy hash, because it is shared with other interfaces. | ||||||
| 8123 | 3 | 4 | my $real_set = $real_intf->{no_nat_set}; | ||||
| 8124 | 3 | 4 | $real_set = $real_intf->{no_nat_set} = { %$real_set }; | ||||
| 8125 | 3 | 3 | my $hardware = $real_intf->{hardware}; | ||||
| 8126 | 3 | 7 | $hardware->{no_nat_set} = $real_set if ref $hardware; | ||||
| 8127 | 3 | 7 | for my $nat_tag (sort keys %$tunnel_set) { | ||||
| 8128 | # debug "Adjust NAT of $real_intf->{name}: $nat_tag"; | ||||||
| 8129 | 3 | 12 | $real_set->{$nat_tag} = 1; | ||||
| 8130 | } | ||||||
| 8131 | } | ||||||
| 8132 | } | ||||||
| 8133 | } | ||||||
| 8134 | 332 | 392 | return; | ||||
| 8135 | } | ||||||
| 8136 | |||||||
| 8137 | sub get_nat_network { | ||||||
| 8138 | 6083 | 0 | 5084 | my ($network, $no_nat_set) = @_; | |||
| 8139 | 6083 | 11050 | if (my $href = $network->{nat} and $no_nat_set) { | ||||
| 8140 | 582 | 920 | for my $tag (keys %$href) { | ||||
| 8141 | 622 | 1178 | next if $no_nat_set->{$tag}; | ||||
| 8142 | 299 | 528 | return $href->{$tag}; | ||||
| 8143 | } | ||||||
| 8144 | } | ||||||
| 8145 | 5784 | 6405 | return $network; | ||||
| 8146 | } | ||||||
| 8147 | |||||||
| 8148 | #################################################################### | ||||||
| 8149 | # Find sub-networks | ||||||
| 8150 | # Mark each network with the smallest network enclosing it. | ||||||
| 8151 | #################################################################### | ||||||
| 8152 | |||||||
| 8153 | # All interfaces and hosts of a network must be located in that part | ||||||
| 8154 | # of the network which doesn't overlap with some subnet. | ||||||
| 8155 | sub check_subnets { | ||||||
| 8156 | 516 | 0 | 451 | my ($network, $subnet) = @_; | |||
| 8157 | 516 | 1303 | return if $network->{is_aggregate} || $subnet->{is_aggregate}; | ||||
| 8158 | 180 180 | 149 261 | my ($sub_ip, $sub_mask) = @{$subnet}{qw(ip mask)}; | ||||
| 8159 | my $check = sub { | ||||||
| 8160 | 150 | 157 | my ($ip1, $ip2, $object) = @_; | ||||
| 8161 | 150 | 180 | if ( | ||||
| 8162 | match_ip($ip1, $sub_ip, $sub_mask) | ||||||
| 8163 | || $ip2 && (match_ip($ip2, $sub_ip, $sub_mask) | ||||||
| 8164 | || ($ip1 <= $sub_ip && $sub_ip <= $ip2)) | ||||||
| 8165 | ) | ||||||
| 8166 | { | ||||||
| 8167 | |||||||
| 8168 | # NAT to an interface address (masquerading) is allowed. | ||||||
| 8169 | 0 | 0 | if ( (my $nat_tags = $object->{bind_nat}) | ||||
| 8170 | and (my ($nat_tag2) = ($subnet->{name} =~ /^nat:(.*)\(/))) | ||||||
| 8171 | { | ||||||
| 8172 | 0 0 | 0 0 | if ( grep { $_ eq $nat_tag2 } @$nat_tags | ||||
| 8173 | and $object->{ip} == $subnet->{ip} | ||||||
| 8174 | and $subnet->{mask} == 0xffffffff) | ||||||
| 8175 | { | ||||||
| 8176 | 0 | 0 | return; | ||||
| 8177 | } | ||||||
| 8178 | } | ||||||
| 8179 | 0 | 0 | warn_msg("$object->{name}'s IP overlaps with subnet", | ||||
| 8180 | " $subnet->{name}"); | ||||||
| 8181 | } | ||||||
| 8182 | 180 | 588 | }; | ||||
| 8183 | 180 180 | 166 241 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 8184 | 350 | 326 | my $ip = $interface->{ip}; | ||||
| 8185 | 350 | 889 | next if $ip =~ /^(?:unnumbered|negotiated|tunnel|short|bridged)$/; | ||||
| 8186 | 145 | 185 | $check->($ip, undef, $interface); | ||||
| 8187 | } | ||||||
| 8188 | 180 180 | 179 248 | for my $host (@{ $network->{hosts} }) { | ||||
| 8189 | 5 | 15 | if (my $ip = $host->{ip}) { | ||||
| 8190 | 5 | 7 | $check->($ip, undef, $host); | ||||
| 8191 | } | ||||||
| 8192 | elsif (my $range = $host->{range}) { | ||||||
| 8193 | 0 | 0 | $check->($range->[0], $range->[1], $host); | ||||
| 8194 | } | ||||||
| 8195 | } | ||||||
| 8196 | 180 | 836 | return; | ||||
| 8197 | } | ||||||
| 8198 | |||||||
| 8199 | # Dynamic NAT to loopback interface is OK, | ||||||
| 8200 | # if NAT is applied at device of loopback interface. | ||||||
| 8201 | sub nat_to_loopback_ok { | ||||||
| 8202 | 3 | 0 | 3 | my ($loopback_network, $nat_network) = @_; | |||
| 8203 | |||||||
| 8204 | 3 | 4 | my $nat_tag1 = $nat_network->{dynamic}; | ||||
| 8205 | 3 | 4 | my $device_count = 0; | ||||
| 8206 | 3 | 3 | my $all_device_ok = 0; | ||||
| 8207 | |||||||
| 8208 | # In case of virtual loopback, the loopback network | ||||||
| 8209 | # is attached to two or more routers. | ||||||
| 8210 | # Loop over these devices. | ||||||
| 8211 | 3 3 | 4 4 | for my $loop_intf (@{ $loopback_network->{interfaces} }) { | ||||
| 8212 | 5 | 5 | $device_count++; | ||||
| 8213 | 5 | 4 | my $this_device_ok = 0; | ||||
| 8214 | |||||||
| 8215 | # Check all interfaces of attached device. | ||||||
| 8216 | 5 5 | 4 9 | for my $all_intf (@{ $loop_intf->{router}->{interfaces} }) { | ||||
| 8217 | 5 | 9 | if (my $nat_tags = $all_intf->{bind_nat}) { | ||||
| 8218 | 5 5 | 6 11 | if (grep { $_ eq $nat_tag1 } @$nat_tags) { | ||||
| 8219 | 5 | 4 | $this_device_ok = 1; | ||||
| 8220 | 5 | 6 | last; | ||||
| 8221 | } | ||||||
| 8222 | } | ||||||
| 8223 | } | ||||||
| 8224 | 5 | 8 | $all_device_ok += $this_device_ok; | ||||
| 8225 | } | ||||||
| 8226 | 3 | 8 | return ($all_device_ok == $device_count); | ||||
| 8227 | } | ||||||
| 8228 | |||||||
| 8229 | 1272 | 0 | 2008 | sub numerically { return $a <=> $b } | |||
| 8230 | 1812 | 0 | 2947 | sub by_name { return $a->{name} cmp $b->{name} } | |||
| 8231 | |||||||
| 8232 | sub link_reroute_permit; | ||||||
| 8233 | |||||||
| 8234 | # Find subnet relation between networks inside a zone. | ||||||
| 8235 | # - $subnet->{up} = $bignet; | ||||||
| 8236 | sub find_subnets_in_zone { | ||||||
| 8237 | 332 | 0 | 457 | progress('Finding subnets in zone'); | |||
| 8238 | 332 | 350 | for my $zone (@zones) { | ||||
| 8239 | |||||||
| 8240 | # Check NAT inside zone. | ||||||
| 8241 | # Find networks of zone which use a NATed address inside the zone. | ||||||
| 8242 | # - Use this NATed address in subnet checks. | ||||||
| 8243 | # - If a subnet relation exists, then this NAT must be unique inside | ||||||
| 8244 | # the zone. | ||||||
| 8245 | |||||||
| 8246 | 882 | 953 | my $first_intf = $zone->{interfaces}->[0]; | ||||
| 8247 | 882 | 706 | my %seen; | ||||
| 8248 | |||||||
| 8249 | # Collect NAT tags, that are defined and applied inside the zone. | ||||||
| 8250 | my %net2zone_nat_tags; | ||||||
| 8251 | |||||||
| 8252 | # Handle different no_nat_sets visible at border of zone. | ||||||
| 8253 | # For a zone without NAT, this loop is executed only once. | ||||||
| 8254 | 882 882 | 672 1032 | for my $interface (@{ $zone->{interfaces} }) { | ||||
| 8255 | 1158 | 1036 | my $no_nat_set = $interface->{no_nat_set}; | ||||
| 8256 | # debug $interface->{name}; | ||||||
| 8257 | 1158 | 2784 | next if $seen{$no_nat_set}++; | ||||
| 8258 | |||||||
| 8259 | # Add networks of zone to %mask_ip_hash. | ||||||
| 8260 | # Use NAT IP/mask. | ||||||
| 8261 | 865 | 635 | my %mask_ip_hash; | ||||
| 8262 | |||||||
| 8263 | 865 865 865 | 642 892 1088 | for my $network (@{ $zone->{networks} }, | ||||
| 8264 | values %{ $zone->{ipmask2aggregate} }) | ||||||
| 8265 | { | ||||||
| 8266 | 1107 | 2520 | next if $network->{ip} =~ /^(?:unnumbered|tunnel)$/; | ||||
| 8267 | |||||||
| 8268 | |||||||
| 8269 | 1107 | 915 | my $nat_network = $network; | ||||
| 8270 | 1107 | 1635 | if (my $href = $network->{nat}) { | ||||
| 8271 | 113 | 182 | for my $tag (keys %$href) { | ||||
| 8272 | 129 | 293 | next if $no_nat_set->{$tag}; | ||||
| 8273 | 16 16 | 15 49 | push @{ $net2zone_nat_tags{$network} }, $tag; | ||||
| 8274 | 16 | 23 | $nat_network = $href->{$tag}; | ||||
| 8275 | 16 | 17 | last; | ||||
| 8276 | } | ||||||
| 8277 | } | ||||||
| 8278 | |||||||
| 8279 | 1107 | 1586 | if ($nat_network->{hidden}) { | ||||
| 8280 | 6 | 16 | my $other = $network->{up} or next; | ||||
| 8281 | 1 | 2 | next if get_nat_network($other, $no_nat_set)->{hidden}; | ||||
| 8282 | 1 | 9 | err_msg("Ambiguous subnet relation from NAT.\n", | ||||
| 8283 | " $network->{name} is subnet of\n", | ||||||
| 8284 | " - $other->{name} at", | ||||||
| 8285 | " $first_intf->{name}\n", | ||||||
| 8286 | " - but it is hidden $nat_network->{name} at", | ||||||
| 8287 | " $interface->{name}"); | ||||||
| 8288 | 1 | 3 | next; | ||||
| 8289 | } | ||||||
| 8290 | 1101 1101 | 842 1639 | my ($ip, $mask) = @{$nat_network}{ 'ip', 'mask' }; | ||||
| 8291 | |||||||
| 8292 | # Found two different networks with identical IP/mask. | ||||||
| 8293 | 1101 | 2297 | if (my $other_net = $mask_ip_hash{$mask}->{$ip}) { | ||||
| 8294 | 1 | 2 | my $name1 = $network->{name}; | ||||
| 8295 | 1 | 2 | my $name2 = $other_net->{name}; | ||||
| 8296 | 1 | 5 | err_msg("$name1 and $name2 have identical IP/mask", | ||||
| 8297 | " at $interface->{name}"); | ||||||
| 8298 | } | ||||||
| 8299 | else { | ||||||
| 8300 | |||||||
| 8301 | # Store original network under NAT IP/mask. | ||||||
| 8302 | 1100 | 2515 | $mask_ip_hash{$mask}->{$ip} = $network; | ||||
| 8303 | } | ||||||
| 8304 | } | ||||||
| 8305 | |||||||
| 8306 | # Compare networks of zone. | ||||||
| 8307 | # Go from smaller to larger networks. | ||||||
| 8308 | 865 | 2215 | my @mask_list = reverse sort numerically keys %mask_ip_hash; | ||||
| 8309 | 865 | 1622 | while (my $mask = shift @mask_list) { | ||||
| 8310 | |||||||
| 8311 | # No supernets available | ||||||
| 8312 | 942 | 2916 | last if not @mask_list; | ||||
| 8313 | |||||||
| 8314 | 130 | 140 | my $ip_hash = $mask_ip_hash{$mask}; | ||||
| 8315 | SUBNET: | ||||||
| 8316 | 130 | 320 | for my $ip (sort numerically keys %$ip_hash) { | ||||
| 8317 | |||||||
| 8318 | 160 | 161 | my $subnet = $ip_hash->{$ip}; | ||||
| 8319 | |||||||
| 8320 | # Find networks which include current subnet. | ||||||
| 8321 | # @mask_list holds masks of potential supernets. | ||||||
| 8322 | 160 | 175 | for my $m (@mask_list) { | ||||
| 8323 | |||||||
| 8324 | 181 | 209 | my $i = $ip & $m; | ||||
| 8325 | 181 | 420 | my $bignet = $mask_ip_hash{$m}->{$i} or next; | ||||
| 8326 | |||||||
| 8327 | # Collect subnet relation for first no_nat_set. | ||||||
| 8328 | 111 | 227 | if ($interface eq $first_intf) { | ||||
| 8329 | 105 | 128 | $subnet->{up} = $bignet; | ||||
| 8330 | # debug "$subnet->{name} -up-> $bignet->{name}"; | ||||||
| 8331 | |||||||
| 8332 | 105 | 235 | push( | ||||
| 8333 | 17 | 36 | @{ $bignet->{networks} }, | ||||
| 8334 | $subnet->{is_aggregate} | ||||||
| 8335 | 105 | 90 | ? @{ $subnet->{networks} || [] } | ||||
| 8336 | : ($subnet) | ||||||
| 8337 | ); | ||||||
| 8338 | |||||||
| 8339 | 105 | 168 | check_subnets($bignet, $subnet); | ||||
| 8340 | } | ||||||
| 8341 | |||||||
| 8342 | # Check for ambiguous subnet relation with | ||||||
| 8343 | # other no_nat_sets. | ||||||
| 8344 | 6 | 10 | else {if (my $other = $subnet->{up}) { | ||||
| 8345 | 5 | 12 | if ($other ne $bignet) { | ||||
| 8346 | 1 | 8 | err_msg( | ||||
| 8347 | "Ambiguous subnet relation from NAT.\n", | ||||||
| 8348 | " $subnet->{name} is subnet of\n", | ||||||
| 8349 | " - $other->{name} at", | ||||||
| 8350 | " $first_intf->{name}\n", | ||||||
| 8351 | " - $bignet->{name} at", | ||||||
| 8352 | " $interface->{name}"); | ||||||
| 8353 | } | ||||||
| 8354 | } | ||||||
| 8355 | else { | ||||||
| 8356 | 1 | 7 | err_msg( | ||||
| 8357 | "Ambiguous subnet relation from NAT.\n", | ||||||
| 8358 | " $subnet->{name} is subnet of\n", | ||||||
| 8359 | " - $bignet->{name} at", | ||||||
| 8360 | " $interface->{name}\n", | ||||||
| 8361 | " - but has no subnet relation at", | ||||||
| 8362 | " $first_intf->{name}"); | ||||||
| 8363 | } | ||||||
| 8364 | } | ||||||
| 8365 | |||||||
| 8366 | # We only need to find the smallest enclosing | ||||||
| 8367 | # network. | ||||||
| 8368 | 111 | 482 | next SUBNET; | ||||
| 8369 | } | ||||||
| 8370 | 49 | 174 | if ($interface ne $first_intf) { | ||||
| 8371 | 3 | 6 | if (my $other = $subnet->{up}) { | ||||
| 8372 | 3 | 16 | err_msg("Ambiguous subnet relation from NAT.\n", | ||||
| 8373 | " $subnet->{name} is subnet of\n", | ||||||
| 8374 | " - $other->{name} at", | ||||||
| 8375 | " $first_intf->{name}\n", | ||||||
| 8376 | " - but has no subnet relation at", | ||||||
| 8377 | " $interface->{name}"); | ||||||
| 8378 | } | ||||||
| 8379 | } | ||||||
| 8380 | } | ||||||
| 8381 | } | ||||||
| 8382 | } | ||||||
| 8383 | |||||||
| 8384 | # For each subnet N find the largest non-aggregate network | ||||||
| 8385 | # which encloses N. If one exists, store it in %max_up_net. | ||||||
| 8386 | # This is used to exclude subnets from $zone->{networks} below. | ||||||
| 8387 | # It is also used to derive attribute {max_routing_net}. | ||||||
| 8388 | 882 | 812 | my %max_up_net; | ||||
| 8389 | my $set_max_net; | ||||||
| 8390 | $set_max_net = sub { | ||||||
| 8391 | 2254 | 2511 | my ($network) = @_; | ||||
| 8392 | 2254 | 4032 | return if not $network; | ||||
| 8393 | 1182 | 2152 | if (my $max_net = $max_up_net{$network}) { | ||||
| 8394 | 4 | 6 | return $max_net; | ||||
| 8395 | } | ||||||
| 8396 | 1178 | 3020 | if (my $max_net = $set_max_net->($network->{up})) { | ||||
| 8397 | 66 | 113 | if (!$network->{is_aggregate}) { | ||||
| 8398 | 56 | 110 | $max_up_net{$network} = $max_net; | ||||
| 8399 | |||||||
| 8400 | # debug("$network->{name} max_up $max_net->{name}"); | ||||||
| 8401 | } | ||||||
| 8402 | 66 | 130 | return $max_net; | ||||
| 8403 | } | ||||||
| 8404 | 1112 | 2009 | if ($network->{is_aggregate}) { | ||||
| 8405 | 40 | 74 | return; | ||||
| 8406 | } | ||||||
| 8407 | 1072 | 1829 | return $network; | ||||
| 8408 | 882 | 2493 | }; | ||||
| 8409 | 882 882 | 758 1912 | $set_max_net->($_) for @{ $zone->{networks} }; | ||||
| 8410 | |||||||
| 8411 | # For each subnet N find the largest non-aggregate network | ||||||
| 8412 | # which encloses N and which has the same NAT settings as N. | ||||||
| 8413 | # If one exists, store it in {max_routing_net}. This is used | ||||||
| 8414 | # for generating static routes. | ||||||
| 8415 | 882 882 | 771 1165 | for my $network (@{ $zone->{networks} }) { | ||||
| 8416 | 1076 | 2540 | my $max = $max_up_net{$network} or next; | ||||
| 8417 | # debug "Check $network->{name} $max->{name}"; | ||||||
| 8418 | |||||||
| 8419 | my $get_zone_nat = sub { | ||||||
| 8420 | 130 | 119 | my ($network) = @_; | ||||
| 8421 | 130 | 337 | my $nat = $network->{nat} || {}; | ||||
| 8422 | |||||||
| 8423 | # Special case: | ||||||
| 8424 | # NAT is applied to $network inside the zone. | ||||||
| 8425 | # Ignore NAT tag when comparing with NAT of $up. | ||||||
| 8426 | 130 | 242 | if (my $aref = $net2zone_nat_tags{$network}) { | ||||
| 8427 | 8 | 18 | $nat = { %$nat }; | ||||
| 8428 | 8 | 12 | for my $nat_tag (@$aref) { | ||||
| 8429 | 8 | 17 | delete $nat->{$nat_tag}; | ||||
| 8430 | } | ||||||
| 8431 | } | ||||||
| 8432 | 130 | 162 | return $nat; | ||||
| 8433 | 56 | 169 | }; | ||||
| 8434 | 56 | 81 | my $nat = $get_zone_nat->($network); | ||||
| 8435 | 56 | 52 | my $max_routing; | ||||
| 8436 | 56 | 61 | my $up = $network->{up}; | ||||
| 8437 | UP: | ||||||
| 8438 | 56 | 93 | while ($up) { | ||||
| 8439 | |||||||
| 8440 | # Check if NAT settings are identical. | ||||||
| 8441 | 74 | 85 | my $up_nat = $get_zone_nat->($up); | ||||
| 8442 | 74 | 161 | keys %$nat == keys %$up_nat or last UP; | ||||
| 8443 | 67 | 124 | for my $tag (keys %$nat) { | ||||
| 8444 | 3 | 6 | my $up_nat_info = $up_nat->{$tag} or last UP; | ||||
| 8445 | 3 | 3 | my $nat_info = $nat->{$tag}; | ||||
| 8446 | 3 | 5 | if ($nat_info->{hidden}) { | ||||
| 8447 | 0 | 0 | $up_nat_info->{hidden} or last UP; | ||||
| 8448 | } | ||||||
| 8449 | else { | ||||||
| 8450 | |||||||
| 8451 | # Check if subnet relation is maintained | ||||||
| 8452 | # for NAT addresses. | ||||||
| 8453 | 3 | 5 | $up_nat_info->{hidden} and last UP; | ||||
| 8454 | 3 3 | 2 4 | my($ip, $mask) = @{$nat_info}{qw(ip mask)}; | ||||
| 8455 | 3 | 7 | match_ip($up_nat_info->{ip}, $ip, $mask) or last UP; | ||||
| 8456 | 1 | 4 | $up_nat_info->{mask} >= $mask or last UP; | ||||
| 8457 | } | ||||||
| 8458 | } | ||||||
| 8459 | 65 | 118 | if (!$up->{is_aggregate}) { | ||||
| 8460 | 50 | 53 | $max_routing = $up; | ||||
| 8461 | } | ||||||
| 8462 | 65 | 135 | $up = $up->{up}; | ||||
| 8463 | } | ||||||
| 8464 | 56 | 109 | if ($max_routing) { | ||||
| 8465 | 49 | 202 | $network->{max_routing_net} = $max_routing; | ||||
| 8466 | # debug "Found $max_routing->{name}"; | ||||||
| 8467 | } | ||||||
| 8468 | } | ||||||
| 8469 | |||||||
| 8470 | # Remove subnets of non-aggregate networks. | ||||||
| 8471 | 1076 | 2438 | $zone->{networks} = | ||||
| 8472 | 882 882 | 800 1039 | [ grep { !$max_up_net{$_} } @{ $zone->{networks} } ]; | ||||
| 8473 | |||||||
| 8474 | # Propagate managed hosts to aggregates. | ||||||
| 8475 | 882 882 | 953 2524 | for my $aggregate (values %{ $zone->{ipmask2aggregate} }) { | ||||
| 8476 | 53 | 105 | add_managed_hosts_to_aggregate($aggregate); | ||||
| 8477 | } | ||||||
| 8478 | } | ||||||
| 8479 | |||||||
| 8480 | # It is valid to have an aggregate in a zone which has no matching | ||||||
| 8481 | # networks. This can be useful to add optimization rules at an | ||||||
| 8482 | # intermediate device. | ||||||
| 8483 | |||||||
| 8484 | # Change NAT at interface after above checks. | ||||||
| 8485 | 332 | 517 | adjust_crypto_nat(); | ||||
| 8486 | |||||||
| 8487 | # Call late after $zone->{networks} has been set up. | ||||||
| 8488 | 332 | 449 | link_reroute_permit(); | ||||
| 8489 | 332 | 429 | check_managed_local(); | ||||
| 8490 | 332 | 278 | return; | ||||
| 8491 | } | ||||||
| 8492 | |||||||
| 8493 | # Find subnet relation inside a NAT domain. | ||||||
| 8494 | # - $subnet->{is_in}->{$no_nat_set} = $bignet; | ||||||
| 8495 | # - $net1->{is_identical}->{$no_nat_set} = $net2 | ||||||
| 8496 | # | ||||||
| 8497 | # Mark networks, having subnet in other zone: $bignet->{has_other_subnet} | ||||||
| 8498 | # If set, this prevents secondary optimization. | ||||||
| 8499 | sub find_subnets_in_nat_domain { | ||||||
| 8500 | 326 | 0 | 311 | my $count = @natdomains; | |||
| 8501 | 326 | 761 | progress("Finding subnets in $count NAT domains"); | ||||
| 8502 | 326 | 310 | my %seen; | ||||
| 8503 | |||||||
| 8504 | 326 | 375 | for my $domain (@natdomains) { | ||||
| 8505 | 437 | 438 | my $no_nat_set = $domain->{no_nat_set}; | ||||
| 8506 | |||||||
| 8507 | # debug("$domain->{name} ", join ',', sort keys %$no_nat_set); | ||||||
| 8508 | 437 | 375 | my %mask_ip_hash; | ||||
| 8509 | my %identical; | ||||||
| 8510 | 437 | 442 | for my $network (@networks) { | ||||
| 8511 | 1768 | 3520 | next if $network->{ip} =~ /^(?:unnumbered|tunnel)$/; | ||||
| 8512 | 1698 | 1940 | my $nat_network = get_nat_network($network, $no_nat_set); | ||||
| 8513 | 1698 | 2460 | next if $nat_network->{hidden}; | ||||
| 8514 | 1663 1663 | 1279 2095 | my ($ip, $mask) = @{$nat_network}{ 'ip', 'mask' }; | ||||
| 8515 | |||||||
| 8516 | # Found two different networks with identical IP/mask. | ||||||
| 8517 | # in current NAT domain. | ||||||
| 8518 | 1663 | 2992 | if (my $old_net = $mask_ip_hash{$mask}->{$ip}) { | ||||
| 8519 | 57 | 71 | my $nat_old_net = get_nat_network($old_net, $no_nat_set); | ||||
| 8520 | 57 | 59 | my $error; | ||||
| 8521 | 57 | 238 | if ($old_net->{is_aggregate} || $network->{is_aggregate}) { | ||||
| 8522 | 41 | 92 | if ($old_net->{zone} eq $network->{zone}) { | ||||
| 8523 | 0 | 0 | $error = 1; | ||||
| 8524 | } | ||||||
| 8525 | else { | ||||||
| 8526 | 41 | 111 | if (!$old_net->{is_aggregate}) { | ||||
| 8527 | |||||||
| 8528 | # This network has aggregate (with | ||||||
| 8529 | # subnets) in other zone. Hence this | ||||||
| 8530 | # network must not be used in secondary | ||||||
| 8531 | # optimization. | ||||||
| 8532 | 0 | 0 | $old_net->{has_other_subnet} = 1; | ||||
| 8533 | } | ||||||
| 8534 | elsif (!$network->{is_aggregate}) { | ||||||
| 8535 | 0 | 0 | $network->{has_other_subnet} = 1; | ||||
| 8536 | } | ||||||
| 8537 | } | ||||||
| 8538 | } | ||||||
| 8539 | elsif ($nat_old_net->{dynamic} and $nat_network->{dynamic}) { | ||||||
| 8540 | |||||||
| 8541 | # Dynamic NAT of different networks | ||||||
| 8542 | # to a single new IP/mask is OK. | ||||||
| 8543 | } | ||||||
| 8544 | elsif ($old_net->{loopback} and $nat_network->{dynamic}) { | ||||||
| 8545 | 3 | 7 | nat_to_loopback_ok($old_net, $nat_network) or $error = 1; | ||||
| 8546 | } | ||||||
| 8547 | elsif ($nat_old_net->{dynamic} and $network->{loopback}) { | ||||||
| 8548 | 0 | 0 | nat_to_loopback_ok($network, $nat_old_net) or $error = 1; | ||||
| 8549 | } | ||||||
| 8550 | elsif (($network->{bridged} || 0) eq ($old_net->{bridged} || 1)) | ||||||
| 8551 | { | ||||||
| 8552 | |||||||
| 8553 | # Parts of bridged network have identical IP by design. | ||||||
| 8554 | } | ||||||
| 8555 | else { | ||||||
| 8556 | 0 | 0 | $error = 1; | ||||
| 8557 | } | ||||||
| 8558 | 57 | 94 | if ($error) { | ||||
| 8559 | 0 | 0 | my $name1 = $nat_network->{name}; | ||||
| 8560 | 0 | 0 | my $name2 = $nat_old_net->{name}; | ||||
| 8561 | 0 | 0 | err_msg("$name1 and $name2 have identical IP/mask\n", | ||||
| 8562 | " in $domain->{name}"); | ||||||
| 8563 | } | ||||||
| 8564 | else { | ||||||
| 8565 | |||||||
| 8566 | # Remember identical networks. | ||||||
| 8567 | 57 | 202 | $identical{$old_net} ||= [$old_net]; | ||||
| 8568 | 57 57 | 53 156 | push @{ $identical{$old_net} }, $network; | ||||
| 8569 | } | ||||||
| 8570 | } | ||||||
| 8571 | else { | ||||||
| 8572 | |||||||
| 8573 | # Store original network under NAT IP/mask. | ||||||
| 8574 | 1606 | 2967 | $mask_ip_hash{$mask}->{$ip} = $network; | ||||
| 8575 | } | ||||||
| 8576 | } | ||||||
| 8577 | |||||||
| 8578 | # Link identical networks to one representative one. | ||||||
| 8579 | 437 | 780 | for my $networks (values %identical) { | ||||
| 8580 | 41 | 127 | $_->{is_supernet} = 1 for @$networks; | ||||
| 8581 | 41 | 59 | my $one_net = shift(@$networks); | ||||
| 8582 | 41 | 50 | for my $network (@$networks) { | ||||
| 8583 | 57 | 171 | $network->{is_identical}->{$no_nat_set} = $one_net; | ||||
| 8584 | # debug("Identical: $network->{name}: $one_net->{name}"); | ||||||
| 8585 | } | ||||||
| 8586 | } | ||||||
| 8587 | |||||||
| 8588 | # Go from smaller to larger networks. | ||||||
| 8589 | 437 | 1163 | my @mask_list = reverse sort numerically keys %mask_ip_hash; | ||||
| 8590 | 437 | 1230 | while (my $mask = shift @mask_list) { | ||||
| 8591 | |||||||
| 8592 | # No supernets available | ||||||
| 8593 | 713 | 1931 | last if not @mask_list; | ||||
| 8594 | |||||||
| 8595 | 373 | 380 | my $ip_hash = $mask_ip_hash{$mask}; | ||||
| 8596 | 373 | 1261 | for my $ip (sort numerically keys %$ip_hash) { | ||||
| 8597 | |||||||
| 8598 | # It is sufficient to set subset relation for only one | ||||||
| 8599 | # network out of multiple identical networks. | ||||||
| 8600 | # In all contexts where {is_in} is used, | ||||||
| 8601 | # we apply {is_identical} to the network before. | ||||||
| 8602 | 703 | 654 | my $subnet = $ip_hash->{$ip}; | ||||
| 8603 | |||||||
| 8604 | # Find networks which include current subnet. | ||||||
| 8605 | # @mask_list holds masks of potential supernets. | ||||||
| 8606 | 703 | 666 | for my $m (@mask_list) { | ||||
| 8607 | 905 | 820 | my $i = $ip & $m; | ||||
| 8608 | 905 | 2071 | my $bignet = $mask_ip_hash{$m}->{$i} or next; | ||||
| 8609 | 527 | 608 | my $nat_subnet = get_nat_network($subnet, $no_nat_set); | ||||
| 8610 | 527 | 623 | my $nat_bignet = get_nat_network($bignet, $no_nat_set); | ||||
| 8611 | |||||||
| 8612 | # Mark subnet relation. | ||||||
| 8613 | # This may differ for different NAT domains. | ||||||
| 8614 | 527 | 950 | $subnet->{is_in}->{$no_nat_set} = $bignet; | ||||
| 8615 | # debug "$subnet->{name} -is_in-> $bignet->{name}"; | ||||||
| 8616 | |||||||
| 8617 | 527 | 1009 | if ($bignet->{zone} eq $subnet->{zone}) { | ||||
| 8618 | 222 | 356 | if ($subnet->{has_other_subnet}) { | ||||
| 8619 | # debug "has other1: $bignet->{name}"; | ||||||
| 8620 | 6 | 9 | $bignet->{has_other_subnet} = 1; | ||||
| 8621 | } | ||||||
| 8622 | } | ||||||
| 8623 | else { | ||||||
| 8624 | # debug "has other: $bignet->{name}"; | ||||||
| 8625 | 305 | 334 | $bignet->{has_other_subnet} = 1; | ||||
| 8626 | } | ||||||
| 8627 | |||||||
| 8628 | # Mark network having subnets. Rules having | ||||||
| 8629 | # src or dst with subnets are collected into | ||||||
| 8630 | # $expanded_rules->{supernet} | ||||||
| 8631 | 527 | 504 | $bignet->{is_supernet} = 1; | ||||
| 8632 | |||||||
| 8633 | 527 | 1161 | if ($seen{$nat_bignet}->{$nat_subnet}) { | ||||
| 8634 | 116 | 283 | last; | ||||
| 8635 | } | ||||||
| 8636 | 411 | 658 | $seen{$nat_bignet}->{$nat_subnet} = 1; | ||||
| 8637 | |||||||
| 8638 | 411 | 643 | if ($config{check_subnets}) { | ||||
| 8639 | |||||||
| 8640 | # Take original $bignet, because currently | ||||||
| 8641 | # there's no method to specify a natted network | ||||||
| 8642 | # as value of subnet_of. | ||||||
| 8643 | 411 | 1362 | if ( | ||||
| 8644 | not( $bignet->{is_aggregate} | ||||||
| 8645 | or $subnet->{is_aggregate} | ||||||
| 8646 | or $bignet->{has_subnets} | ||||||
| 8647 | or $nat_subnet->{subnet_of} | ||||||
| 8648 | and $nat_subnet->{subnet_of} eq $bignet | ||||||
| 8649 | or $nat_subnet->{is_layer3}) | ||||||
| 8650 | ) | ||||||
| 8651 | { | ||||||
| 8652 | |||||||
| 8653 | # Prevent multiple error messages in | ||||||
| 8654 | # different NAT domains. | ||||||
| 8655 | 2 | 8 | $nat_subnet->{subnet_of} ||= $bignet; | ||||
| 8656 | |||||||
| 8657 | 2 | 14 | my $msg = | ||||
| 8658 | "$nat_subnet->{name} is subnet of" | ||||||
| 8659 | . " $nat_bignet->{name}\n" | ||||||
| 8660 | . " in $domain->{name}.\n" | ||||||
| 8661 | . " If desired, either declare attribute" | ||||||
| 8662 | . " 'subnet_of' or attribute 'has_subnets'"; | ||||||
| 8663 | |||||||
| 8664 | 2 | 6 | if ($config{check_subnets} eq 'warn') { | ||||
| 8665 | 2 | 4 | warn_msg($msg); | ||||
| 8666 | } | ||||||
| 8667 | else { | ||||||
| 8668 | 0 | 0 | err_msg($msg); | ||||
| 8669 | } | ||||||
| 8670 | } | ||||||
| 8671 | } | ||||||
| 8672 | |||||||
| 8673 | 411 | 491 | check_subnets($nat_bignet, $nat_subnet); | ||||
| 8674 | 411 | 1316 | last; | ||||
| 8675 | } | ||||||
| 8676 | } | ||||||
| 8677 | } | ||||||
| 8678 | } | ||||||
| 8679 | |||||||
| 8680 | # Secondary optimization substitutes a host or interface by its | ||||||
| 8681 | # largest valid supernet inside the same security zone. This | ||||||
| 8682 | # supernet has already been calculated and stored in | ||||||
| 8683 | # {max_routing_net}. But {max_routing_net} can't be used if it has | ||||||
| 8684 | # a subnet in some other security zone. In this case we have to | ||||||
| 8685 | # search again for a supernet without attribute {has_other_subnet}. | ||||||
| 8686 | # The result is stored in {max_secondary_net}. | ||||||
| 8687 | 326 | 430 | for my $network (@networks) { | ||||
| 8688 | 1239 | 2114 | my $max = $network->{max_routing_net} or next; | ||||
| 8689 | 49 | 92 | if(!$max->{has_other_subnet}) { | ||||
| 8690 | 22 | 37 | $network->{max_secondary_net} = $max; | ||||
| 8691 | 22 | 26 | next; | ||||
| 8692 | } | ||||||
| 8693 | 27 | 28 | my $max_secondary; | ||||
| 8694 | 27 | 30 | my $up = $network->{up}; | ||||
| 8695 | 27 | 43 | while ($up) { | ||||
| 8696 | 29 | 45 | if ($up->{has_other_subnet}) { | ||||
| 8697 | 27 | 20 | last; | ||||
| 8698 | } | ||||||
| 8699 | else { | ||||||
| 8700 | 2 | 4 | if (!$up->{is_aggregate}) { | ||||
| 8701 | 1 | 1 | $max_secondary = $up; | ||||
| 8702 | } | ||||||
| 8703 | 2 | 3 | $up = $up->{up}; | ||||
| 8704 | } | ||||||
| 8705 | } | ||||||
| 8706 | 27 | 51 | $network->{max_secondary_net} = $max_secondary if $max_secondary; | ||||
| 8707 | } | ||||||
| 8708 | 326 | 490 | return; | ||||
| 8709 | } | ||||||
| 8710 | |||||||
| 8711 | ############################################################################# | ||||||
| 8712 | # Purpose : Moves attribute 'no_in_acl' from interfaces to hardware because | ||||||
| 8713 | # ACLs operate on hardware, not on logic. Marks hardware needing | ||||||
| 8714 | # outgoing ACLs. | ||||||
| 8715 | # Comments : Not more than 1 'no_in_acl' interface/router allowed. | ||||||
| 8716 | sub check_no_in_acl { | ||||||
| 8717 | |||||||
| 8718 | # Process every managed router | ||||||
| 8719 | 337 | 0 | 393 | for my $router (@managed_routers) { | |||
| 8720 | 485 | 394 | my $counter = 0; # count 'no_in_acl' interfaces/router | ||||
| 8721 | |||||||
| 8722 | # At interfaces with no_in_acl move attribute to hardware | ||||||
| 8723 | 485 485 | 399 603 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 8724 | 1112 | 1949 | if (delete $interface->{no_in_acl}) { | ||||
| 8725 | 7 | 13 | my $hardware = $interface->{hardware}; | ||||
| 8726 | 7 | 13 | $hardware->{no_in_acl} = 1; | ||||
| 8727 | |||||||
| 8728 | # Assure max number of main interfaces at no_in_acl-hardware =1 | ||||||
| 8729 | 7 | 25 | 1 == | ||||
| 8730 | grep( | ||||||
| 8731 | 7 7 | 9 13 | { not $_->{main_interface} } @{ $hardware->{interfaces} }) | ||||
| 8732 | or err_msg | ||||||
| 8733 | "Only one logical interface allowed at $hardware->{name}", | ||||||
| 8734 | " because it has attribute 'no_in_acl'"; | ||||||
| 8735 | 7 | 7 | $counter++; | ||||
| 8736 | |||||||
| 8737 | # Reference no_in_acl interface in router attribute | ||||||
| 8738 | 7 | 12 | $router->{no_in_acl} = $interface; | ||||
| 8739 | } | ||||||
| 8740 | } | ||||||
| 8741 | 485 | 965 | next if not $counter; | ||||
| 8742 | |||||||
| 8743 | # Assert maximum number of 'no_in_acl' interfaces per router | ||||||
| 8744 | 7 | 15 | $counter == 1 | ||||
| 8745 | or err_msg "At most one interface of $router->{name}", | ||||||
| 8746 | " may use flag 'no_in_acl'"; | ||||||
| 8747 | |||||||
| 8748 | # Assert router to support outgoing ACL | ||||||
| 8749 | 7 | 17 | $router->{model}->{has_out_acl} | ||||
| 8750 | or err_msg("$router->{name} doesn't support outgoing ACL"); | ||||||
| 8751 | |||||||
| 8752 | # Assert router not to take part in crypto tunnels | ||||||
| 8753 | 7 23 7 | 12 84 10 | if (grep { $_->{hub} or $_->{spoke} } @{ $router->{interfaces} }) { | ||||
| 8754 | 0 | 0 | err_msg "Don't use attribute 'no_in_acl' together", | ||||
| 8755 | " with crypto tunnel at $router->{name}"; | ||||||
| 8756 | } | ||||||
| 8757 | |||||||
| 8758 | # Mark other hardware with attribute 'need_out_acl'. | ||||||
| 8759 | 7 7 | 10 11 | for my $hardware (@{ $router->{hardware} }) { | ||||
| 8760 | 22 | 48 | $hardware->{no_in_acl} | ||||
| 8761 | or $hardware->{need_out_acl} = 1; | ||||||
| 8762 | } | ||||||
| 8763 | } | ||||||
| 8764 | 337 | 319 | return; | ||||
| 8765 | } | ||||||
| 8766 | |||||||
| 8767 | # If routers are connected by crosslink network then | ||||||
| 8768 | # no filter is needed if both have equal strength. | ||||||
| 8769 | # If routers have different strength, | ||||||
| 8770 | # then only the weakest devices omit the filter. | ||||||
| 8771 | my %crosslink_strength = ( | ||||||
| 8772 | primary => 10, | ||||||
| 8773 | full => 10, | ||||||
| 8774 | standard => 9, | ||||||
| 8775 | secondary => 8, | ||||||
| 8776 | local => 7, | ||||||
| 8777 | local_secondary => 6, | ||||||
| 8778 | ); | ||||||
| 8779 | ############################################################################## | ||||||
| 8780 | # Find clusters of routers connected directly or indirectly by | ||||||
| 8781 | # crosslink networks and having at least one device with | ||||||
| 8782 | # "need_protect". | ||||||
| 8783 | sub cluster_crosslink_routers { | ||||||
| 8784 | 337 | 0 | 345 | my ($crosslink_routers) = @_; | |||
| 8785 | 337 | 287 | my %cluster; | ||||
| 8786 | my %seen; | ||||||
| 8787 | 0 | 0 | my $walk; | ||||
| 8788 | |||||||
| 8789 | # add routers to cluster via depth first search | ||||||
| 8790 | $walk = sub { | ||||||
| 8791 | 17 | 15 | my ($router) = @_; | ||||
| 8792 | 17 | 24 | $cluster{$router} = $router; | ||||
| 8793 | 17 | 25 | $seen{$router} = $router; | ||||
| 8794 | 17 17 | 12 20 | for my $in_intf (@{ $router->{interfaces} }) { | ||||
| 8795 | 36 | 34 | my $network = $in_intf->{network}; | ||||
| 8796 | 36 | 63 | next if not $network->{crosslink}; | ||||
| 8797 | 18 | 24 | next if $network->{disabled}; | ||||
| 8798 | 18 18 | 15 20 | for my $out_intf (@{ $network->{interfaces} }) { | ||||
| 8799 | 42 | 81 | next if $out_intf eq $in_intf; | ||||
| 8800 | 24 | 24 | my $router2 = $out_intf->{router}; | ||||
| 8801 | 24 | 60 | next if $cluster{$router2}; | ||||
| 8802 | 9 | 21 | $walk->($router2); | ||||
| 8803 | } | ||||||
| 8804 | } | ||||||
| 8805 | 337 | 1099 | }; | ||||
| 8806 | |||||||
| 8807 | # Process all need_protect crosslinked routers | ||||||
| 8808 | 337 | 725 | for my $router (values %$crosslink_routers) { | ||||
| 8809 | 10 | 19 | next if $seen{$router}; | ||||
| 8810 | |||||||
| 8811 | # Fill router cluster | ||||||
| 8812 | 8 | 9 | %cluster = (); | ||||
| 8813 | 8 | 12 | $walk->($router); | ||||
| 8814 | |||||||
| 8815 | # Collect all interfaces belonging to need_protect routers of cluster... | ||||||
| 8816 | 21 | 33 | my @crosslink_interfaces = | ||||
| 8817 | 10 | 15 | grep { !$_->{vip} } | ||||
| 8818 | 10 17 | 9 27 | map { @{ $_->{interfaces} } } | ||||
| 8819 | 8 | 27 | grep { $crosslink_routers->{$_} } | ||||
| 8820 | sort by_name values %cluster; # Sort to make output deterministic. | ||||||
| 8821 | |||||||
| 8822 | # ... add information to every cluster member | ||||||
| 8823 | 8 20 | 9 47 | my %crosslink_intf_hash = map { $_ => $_ } @crosslink_interfaces; | ||||
| 8824 | 8 | 11 | for my $router2 (values %cluster) { | ||||
| 8825 | # ... as list used in "protect own interfaces" | ||||||
| 8826 | 17 | 20 | $router2->{crosslink_interfaces} = \@crosslink_interfaces; | ||||
| 8827 | # ... as hash used in fast lookup in distribute_rule and "protect.." | ||||||
| 8828 | 17 | 31 | $router2->{crosslink_intf_hash} = \%crosslink_intf_hash; | ||||
| 8829 | } | ||||||
| 8830 | } | ||||||
| 8831 | 337 | 466 | return; | ||||
| 8832 | } | ||||||
| 8833 | ############################################################################## | ||||||
| 8834 | # A crosslink network combines two or more routers to one virtual router. | ||||||
| 8835 | # Purpose : Assures proper usage of crosslink networks and applies the | ||||||
| 8836 | # crosslink attribute to the networks weakest interfaces (no | ||||||
| 8837 | # filtering needed at these interfaces). | ||||||
| 8838 | # Comments : Function uses hardware attributes from sub check_no_in_acl. | ||||||
| 8839 | sub check_crosslink { | ||||||
| 8840 | 337 | 0 | 290 | my %crosslink_routers; # Collect crosslinked routers with {need_protect} | |||
| 8841 | |||||||
| 8842 | # Process all crosslink networks | ||||||
| 8843 | 337 | 528 | for my $network (values %networks) { | ||||
| 8844 | 1115 | 1888 | next if not $network->{crosslink}; | ||||
| 8845 | 10 | 19 | next if $network->{disabled}; | ||||
| 8846 | |||||||
| 8847 | # Prepare tests. | ||||||
| 8848 | 10 | 7 | my %strength2intf;# To identify interfaces with min router strength | ||||
| 8849 | 10 | 8 | my $out_acl_count = 0; # Assure out_ACL at all/none of the interfaces | ||||
| 8850 | 10 | 10 | my @no_in_acl_intf; # Assure all no_in_acl IFs to border the same zone | ||||
| 8851 | |||||||
| 8852 | # Process network interfaces to fill above variables. | ||||||
| 8853 | 10 10 | 6 16 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 8854 | 19 | 28 | next if $interface->{main_interface}; | ||||
| 8855 | 18 | 18 | my $router = $interface->{router}; | ||||
| 8856 | 18 | 17 | my $hardware = $interface->{hardware}; | ||||
| 8857 | |||||||
| 8858 | # Assure correct usage of crosslink network. | ||||||
| 8859 | 18 | 25 | if (!$router->{managed}) { | ||||
| 8860 | 1 | 4 | err_msg("Crosslink $network->{name} must not be", | ||||
| 8861 | " connected to unmanged $router->{name}"); | ||||||
| 8862 | 1 | 2 | next; | ||||
| 8863 | } | ||||||
| 8864 | 17 18 17 | 17 44 20 | 1 == grep({ !$_->{main_interface} } @{ $hardware->{interfaces} }) | ||||
| 8865 | or err_msg | ||||||
| 8866 | "Crosslink $network->{name} must be the only network\n", | ||||||
| 8867 | " connected to $hardware->{name} of $router->{name}"; | ||||||
| 8868 | |||||||
| 8869 | # Fill variables. | ||||||
| 8870 | 17 | 18 | my $managed = $router->{managed}; | ||||
| 8871 | 17 | 29 | my $strength = $crosslink_strength{$managed} or | ||||
| 8872 | internal_err("Unexptected managed=$managed"); | ||||||
| 8873 | 17 17 | 13 34 | push @{ $strength2intf{$strength} }, $interface; | ||||
| 8874 | |||||||
| 8875 | 17 | 29 | if ($router->{need_protect}) { | ||||
| 8876 | 10 | 18 | $crosslink_routers{$router} = $router; | ||||
| 8877 | } | ||||||
| 8878 | |||||||
| 8879 | 17 | 26 | if ($hardware->{need_out_acl}) { | ||||
| 8880 | 0 | 0 | $out_acl_count++; | ||||
| 8881 | } | ||||||
| 8882 | |||||||
| 8883 | 36 | 49 | push @no_in_acl_intf, | ||||
| 8884 | 17 17 | 12 18 | grep({ $_->{hardware}->{no_in_acl} } @{ $router->{interfaces} }); | ||||
| 8885 | } | ||||||
| 8886 | |||||||
| 8887 | # Apply attribute {crosslink} to the networks weakest interfaces. | ||||||
| 8888 | 10 | 32 | if (my ($weakest) = sort numerically keys %strength2intf) { | ||||
| 8889 | 8 8 | 7 11 | for my $interface (@{ $strength2intf{$weakest} }) { | ||||
| 8890 | 13 | 21 | $interface->{hardware}->{crosslink} = 1; | ||||
| 8891 | } | ||||||
| 8892 | |||||||
| 8893 | # Assure 'secondary' and 'local' are not mixed in crosslink network. | ||||||
| 8894 | 8 | 25 | if ($weakest == $crosslink_strength{local} && | ||||
| 8895 | $strength2intf{$crosslink_strength{secondary}}) { | ||||||
| 8896 | 1 | 4 | err_msg("Must not use 'managed=local' and 'managed=secondary'", | ||||
| 8897 | " together\n at crosslink $network->{name}"); | ||||||
| 8898 | } | ||||||
| 8899 | } | ||||||
| 8900 | |||||||
| 8901 | # Assure proper usage of crosslink network. | ||||||
| 8902 | 0 | 0 | not $out_acl_count | ||||
| 8903 | 10 | 23 | or $out_acl_count == @{ $network->{interfaces} } | ||||
| 8904 | or err_msg "All interfaces must equally use or not use outgoing ACLs", | ||||||
| 8905 | " at crosslink $network->{name}"; | ||||||
| 8906 | 10 0 | 18 0 | equal(map { $_->{zone} } @no_in_acl_intf) | ||||
| 8907 | or err_msg "All interfaces with attribute 'no_in_acl'", | ||||||
| 8908 | " at routers connected by\n crosslink $network->{name}", | ||||||
| 8909 | " must be border of the same security zone"; | ||||||
| 8910 | } | ||||||
| 8911 | 337 | 492 | return \%crosslink_routers; | ||||
| 8912 | } | ||||||
| 8913 | |||||||
| 8914 | # Find cluster of zones connected by 'local' or 'local_secondary' routers. | ||||||
| 8915 | # - Check consistency of attributes. | ||||||
| 8916 | # - Set unique 'local_mark' for all zones belonging to one cluster | ||||||
| 8917 | # - Set 'local_secondary_mark' for secondary optimization inside one cluster. | ||||||
| 8918 | # Two zones get the same mark if they are connected by local_secondary router. | ||||||
| 8919 | sub check_managed_local { | ||||||
| 8920 | 332 | 0 | 259 | my %seen; | |||
| 8921 | 332 | 309 | my $cluster_counter = 1; | ||||
| 8922 | 332 | 357 | for my $router (@managed_routers) { | ||||
| 8923 | 485 | 1144 | $router->{managed} =~ /^local/ or next; | ||||
| 8924 | 27 | 60 | next if $seen{$router}; | ||||
| 8925 | |||||||
| 8926 | # Networks of current cluster matching {filter_only}. | ||||||
| 8927 | 20 | 14 | my %matched; | ||||
| 8928 | |||||||
| 8929 | my $walk; | ||||||
| 8930 | $walk = sub { | ||||||
| 8931 | 27 | 29 | my ($router) = @_; | ||||
| 8932 | 27 | 28 | my $filter_only = $router->{filter_only}; | ||||
| 8933 | 27 | 19 | my $k; | ||||
| 8934 | 27 | 45 | $seen{$router} = $router; | ||||
| 8935 | 27 27 | 22 33 | for my $in_intf (@{ $router->{interfaces} }) { | ||||
| 8936 | 54 | 48 | my $no_nat_set = $in_intf->{no_nat_set}; | ||||
| 8937 | 54 | 44 | my $zone0 = $in_intf->{zone}; | ||||
| 8938 | 54 | 42 | my $zone_cluster = $zone0->{zone_cluster}; | ||||
| 8939 | 54 | 77 | for my $zone ($zone_cluster ? @$zone_cluster : ($zone0)) { | ||||
| 8940 | 54 | 79 | next if $zone->{disabled}; | ||||
| 8941 | 54 | 91 | next if $zone->{local_mark}; | ||||
| 8942 | 44 | 44 | $zone->{local_mark} = $cluster_counter; | ||||
| 8943 | |||||||
| 8944 | # All networks in local zone must match {filter_only}. | ||||||
| 8945 | 44 | 44 | NETWORK: | ||||
| 8946 | 44 44 | 33 56 | for my $network (@{ $zone->{networks} }, | ||||
| 8947 | values %{ $zone->{ipmask2aggregate} }) | ||||||
| 8948 | { | ||||||
| 8949 | 46 46 | 31 58 | my ($ip, $mask) = @{ address($network, $no_nat_set) }; | ||||
| 8950 | |||||||
| 8951 | # Ignore aggregate 0/0 which is available in | ||||||
| 8952 | # every zone. | ||||||
| 8953 | 46 | 100 | next if $mask == 0 && $network->{is_aggregate}; | ||||
| 8954 | 45 | 51 | for my $pair (@$filter_only) { | ||||
| 8955 | 50 | 56 | my ($i, $m) = @$pair; | ||||
| 8956 | 50 | 103 | if ($mask >= $m && match_ip($ip, $i, $m)) { | ||||
| 8957 | 42 | 98 | $matched{"$i/$m"} = 1; | ||||
| 8958 | 42 | 90 | next NETWORK; | ||||
| 8959 | } | ||||||
| 8960 | } | ||||||
| 8961 | 3 | 12 | err_msg("$network->{name} doesn't match attribute", | ||||
| 8962 | " 'filter_only' of $router->{name}"); | ||||||
| 8963 | } | ||||||
| 8964 | 44 44 | 38 57 | for my $out_intf (@{ $zone->{interfaces} }) { | ||||
| 8965 | 66 | 207 | next if $out_intf eq $in_intf; | ||||
| 8966 | 22 | 22 | my $router2 = $out_intf->{router}; | ||||
| 8967 | 22 | 38 | my $managed = $router2->{managed} or next; | ||||
| 8968 | 22 | 62 | next if $managed !~ /^local/; | ||||
| 8969 | 10 | 23 | next if $seen{$router2}; | ||||
| 8970 | |||||||
| 8971 | # All routers of a cluster must have same values in | ||||||
| 8972 | # {filter_only}. | ||||||
| 8973 | 7 7 | 17 26 | $k ||= join(',', map({ join('/', @$_) } | ||||
| 8974 | @$filter_only)); | ||||||
| 8975 | 8 7 | 22 15 | my $k2 = join(',', map({ join('/', @$_) } | ||||
| 8976 | 7 | 11 | @{ $router2->{filter_only} })); | ||||
| 8977 | 7 | 18 | $k2 eq $k or | ||||
| 8978 | err_msg("$router->{name} and $router2->{name}", | ||||||
| 8979 | " must have identical values in", | ||||||
| 8980 | " attribute 'filter_only'"); | ||||||
| 8981 | |||||||
| 8982 | 7 | 23 | $walk->($router2); | ||||
| 8983 | } | ||||||
| 8984 | } | ||||||
| 8985 | } | ||||||
| 8986 | 20 | 96 | }; | ||||
| 8987 | |||||||
| 8988 | 20 | 32 | $walk->($router); | ||||
| 8989 | 20 | 15 | $cluster_counter++; | ||||
| 8990 | |||||||
| 8991 | 20 20 | 17 27 | for my $pair (@{ $router->{filter_only} }) { | ||||
| 8992 | 25 | 25 | my ($i, $m) = @$pair; | ||||
| 8993 | 25 | 82 | $matched{"$i/$m"} and next; | ||||
| 8994 | 1 | 2 | my $ip = print_ip($i); | ||||
| 8995 | 1 | 2 | my $prefix = mask2prefix($m); | ||||
| 8996 | 1 | 5 | warn_msg("Useless $ip/$prefix in attribute 'filter_only'", | ||||
| 8997 | " of $router->{name}"); | ||||||
| 8998 | } | ||||||
| 8999 | } | ||||||
| 9000 | 332 | 391 | return; | ||||
| 9001 | } | ||||||
| 9002 | |||||||
| 9003 | # group of reroute_permit networks must be expanded late, after areas, | ||||||
| 9004 | # aggregates and subnets have been set up. Otherwise automatic groups | ||||||
| 9005 | # wouldn't work. | ||||||
| 9006 | # | ||||||
| 9007 | # Reroute permit is not allowed between different security zones. | ||||||
| 9008 | sub link_reroute_permit { | ||||||
| 9009 | 332 | 0 | 374 | for my $zone (@zones) { | |||
| 9010 | 882 882 | 673 1057 | for my $interface (@{ $zone->{interfaces} }) { | ||||
| 9011 | 1158 | 2432 | my $group = $interface->{reroute_permit} or next; | ||||
| 9012 | 2 | 6 | $group = | ||||
| 9013 | expand_group($group, "'reroute_permit' of $interface->{name}"); | ||||||
| 9014 | 2 | 3 | my @checked; | ||||
| 9015 | 2 | 2 | for my $obj (@$group) { | ||||
| 9016 | 2 | 3 | if (is_network($obj)) { | ||||
| 9017 | 2 | 2 | my $net_zone = $obj->{zone}; | ||||
| 9018 | 2 | 4 | if (!zone_eq($net_zone, $zone)) { | ||||
| 9019 | 0 | 0 | err_msg("Invalid reroute_permit for $obj->{name} ", | ||||
| 9020 | "at $interface->{name}:", | ||||||
| 9021 | " different security zones"); | ||||||
| 9022 | } | ||||||
| 9023 | else { | ||||||
| 9024 | 2 | 4 | push @checked, $obj; | ||||
| 9025 | } | ||||||
| 9026 | } | ||||||
| 9027 | else { | ||||||
| 9028 | 0 | 0 | err_msg("$obj->{name} not allowed in attribute", | ||||
| 9029 | " 'reroute_permit' of $interface->{name}"); | ||||||
| 9030 | } | ||||||
| 9031 | } | ||||||
| 9032 | 2 | 6 | $interface->{reroute_permit} = \@checked; | ||||
| 9033 | } | ||||||
| 9034 | } | ||||||
| 9035 | 332 | 326 | return; | ||||
| 9036 | } | ||||||
| 9037 | |||||||
| 9038 | ############################################################################## | ||||||
| 9039 | # Purpose : | ||||||
| 9040 | sub add_managed_hosts_to_aggregate { | ||||||
| 9041 | 160 | 0 | 140 | my ($aggregate) = @_; | |||
| 9042 | |||||||
| 9043 | # Collect managed hosts of sub-networks. | ||||||
| 9044 | 160 | 160 | my $networks = $aggregate->{networks}; | ||||
| 9045 | 160 | 225 | if (@$networks) { | ||||
| 9046 | 127 | 162 | for my $network (@$networks) { | ||||
| 9047 | 147 | 355 | my $managed_hosts = $network->{managed_hosts} or next; | ||||
| 9048 | 2 2 | 2 6 | push(@{ $aggregate->{managed_hosts} }, @$managed_hosts); | ||||
| 9049 | } | ||||||
| 9050 | } | ||||||
| 9051 | |||||||
| 9052 | # Collect matching managed hosts of all networks of zone. | ||||||
| 9053 | # Ignore sub-networks of aggregate, because they would have been | ||||||
| 9054 | # found in $networks above. | ||||||
| 9055 | else { | ||||||
| 9056 | 33 33 | 42 51 | my ($ip, $mask) = @{$aggregate}{qw(ip mask)}; | ||||
| 9057 | 33 | 33 | my $zone = $aggregate->{zone}; | ||||
| 9058 | 33 33 | 1069 48 | for my $network (@{ $zone->{networks} }) { | ||||
| 9059 | 30 | 76 | next if $network->{mask} > $mask ; | ||||
| 9060 | 10 | 29 | my $managed_hosts = $network->{managed_hosts} or next; | ||||
| 9061 | 1 2 | 3 4 | push(@{ $aggregate->{managed_hosts} }, | ||||
| 9062 | 1 | 1 | grep { match_ip($_->{ip}, $ip, $mask) } @$managed_hosts); | ||||
| 9063 | } | ||||||
| 9064 | } | ||||||
| 9065 | 160 | 249 | return; | ||||
| 9066 | } | ||||||
| 9067 | |||||||
| 9068 | #################################################################### | ||||||
| 9069 | # Borders of security zones are | ||||||
| 9070 | # a) interfaces of managed devices and | ||||||
| 9071 | # b) interfaces of devices, which have at least one pathrestriction applied. | ||||||
| 9072 | # | ||||||
| 9073 | # For each security zone create a zone object. | ||||||
| 9074 | # Link each interface at the border with the zone and vice versa. | ||||||
| 9075 | # Additionally link each network and unmanaged router with the zone. | ||||||
| 9076 | # Add a list of all its numbered networks to the zone. | ||||||
| 9077 | #################################################################### | ||||||
| 9078 | |||||||
| 9079 | ############################################################################## | ||||||
| 9080 | # Purpose : Link aggregate and zone via references in both objects, set | ||||||
| 9081 | # aggregate properties according to those of the linked zone. | ||||||
| 9082 | # Store aggregates in @networks (providing all srcs and dsts). | ||||||
| 9083 | sub link_aggregate_to_zone { | ||||||
| 9084 | 160 | 0 | 185 | my ($aggregate, $zone, $key) = @_; | |||
| 9085 | |||||||
| 9086 | # Link aggregate with zone. | ||||||
| 9087 | 160 | 180 | $aggregate->{zone} = $zone; | ||||
| 9088 | 160 | 221 | $zone->{ipmask2aggregate}->{$key} = $aggregate; | ||||
| 9089 | |||||||
| 9090 | # Take a new array for each aggregate, otherwise we would share | ||||||
| 9091 | # the same array between different aggregates. | ||||||
| 9092 | 160 | 372 | $aggregate->{networks} ||= [];# Has to be initialized, even if it is empty | ||||
| 9093 | |||||||
| 9094 | # Set aggregate properties | ||||||
| 9095 | 160 | 256 | $zone->{is_tunnel} and $aggregate->{is_tunnel} = 1; | ||||
| 9096 | 160 | 242 | $zone->{has_id_hosts} and $aggregate->{has_id_hosts} = 1; | ||||
| 9097 | |||||||
| 9098 | 160 | 224 | if ($zone->{disabled}) { | ||||
| 9099 | 0 | 0 | $aggregate->{disabled} = 1; | ||||
| 9100 | } | ||||||
| 9101 | |||||||
| 9102 | # Store aggregate reference in global network hash | ||||||
| 9103 | else { | ||||||
| 9104 | 160 | 174 | push @networks, $aggregate; # @networks provides all srcs/dsts | ||||
| 9105 | } | ||||||
| 9106 | 160 | 222 | return; | ||||
| 9107 | } | ||||||
| 9108 | |||||||
| 9109 | ############################################################################## | ||||||
| 9110 | # Update relations {networks}, {up} and {owner} for implicitly defined | ||||||
| 9111 | # aggregates. | ||||||
| 9112 | # Remember: | ||||||
| 9113 | # {up} is relation inside set of all networks and aggregates. | ||||||
| 9114 | # {networks} is attribute of aggregates and networks, | ||||||
| 9115 | # but value is list of networks. | ||||||
| 9116 | sub link_implicit_aggregate_to_zone { | ||||||
| 9117 | 107 | 0 | 120 | my ($aggregate, $zone, $key) = @_; | |||
| 9118 | 107 | 226 | my ($ip, $mask) = split '/', $key; | ||||
| 9119 | 107 | 121 | my $ipmask2aggregate = $zone->{ipmask2aggregate}; | ||||
| 9120 | |||||||
| 9121 | # Collect all aggregates, networks and subnets of current zone. | ||||||
| 9122 | # Get aggregates in deterministic order. | ||||||
| 9123 | 107 107 | 145 132 | my @objects = @{$ipmask2aggregate}{ sort keys %$ipmask2aggregate }; | ||||
| 9124 | 107 | 95 | my $add_subnets; | ||||
| 9125 | $add_subnets = sub { | ||||||
| 9126 | 129 | 127 | my ($network) = @_; | ||||
| 9127 | 129 | 363 | my $subnets = $network->{networks} or return; | ||||
| 9128 | 3 | 1 | push @objects, @$subnets; | ||||
| 9129 | 3 | 9 | $add_subnets->($_) for @$subnets; | ||||
| 9130 | 107 | 298 | }; | ||||
| 9131 | 107 107 | 93 156 | push @objects, @{ $zone->{networks} }; | ||||
| 9132 | 107 107 | 89 218 | $add_subnets->($_) for @{ $zone->{networks} }; | ||||
| 9133 | |||||||
| 9134 | # Collect all objects being larger and smaller than new aggregate. | ||||||
| 9135 | 107 144 | 128 287 | my @larger = grep { $_->{mask} < $mask } @objects; | ||||
| 9136 | 107 144 | 102 233 | my @smaller = grep { $_->{mask} > $mask } @objects; | ||||
| 9137 | |||||||
| 9138 | # Find subnets of new aggregate. | ||||||
| 9139 | 107 | 124 | for my $obj (@smaller) { | ||||
| 9140 | 132 132 | 105 192 | my ($i, $m) = @{$obj}{qw(ip mask)}; | ||||
| 9141 | 132 | 178 | match_ip($i, $ip, $mask) or next; | ||||
| 9142 | |||||||
| 9143 | # Ignore sub-subnets, i.e. supernet is smaller than new aggregate. | ||||||
| 9144 | 117 | 205 | if (my $up = $obj->{up}) { | ||||
| 9145 | 15 | 31 | next if $up->{mask} >= $mask; | ||||
| 9146 | } | ||||||
| 9147 | 105 | 114 | $obj->{up} = $aggregate; | ||||
| 9148 | # debug "$obj->{name} -up1-> $aggregate->{name}"; | ||||||
| 9149 | 105 9 | 301 17 | push(@{ $aggregate->{networks} }, | ||||
| 9150 | 105 | 92 | $obj->{is_aggregate} ? @{ $obj->{networks} } : $obj); | ||||
| 9151 | } | ||||||
| 9152 | |||||||
| 9153 | # Find supernet of new aggregate. | ||||||
| 9154 | # Iterate from smaller to larger supernets. | ||||||
| 9155 | # Stop after smallest supernet has been found. | ||||||
| 9156 | 107 3 | 190 5 | for my $obj (sort { $a->{mask} < $b->{mask} } @larger) { | ||||
| 9157 | 8 8 | 9 11 | my ($i, $m) = @{$obj}{qw(ip mask)}; | ||||
| 9158 | 8 | 11 | match_ip($ip, $i, $m) or next; | ||||
| 9159 | 7 | 10 | $aggregate->{up} = $obj; | ||||
| 9160 | # debug "$aggregate->{name} -up2-> $obj->{name}"; | ||||||
| 9161 | 7 | 8 | last; | ||||
| 9162 | } | ||||||
| 9163 | |||||||
| 9164 | # Inherit owner from smallest supernet having owner or from zone. | ||||||
| 9165 | 107 | 115 | my $up = $aggregate->{up}; | ||||
| 9166 | 107 | 91 | my $owner; | ||||
| 9167 | 107 | 190 | while ($up) { | ||||
| 9168 | 7 | 12 | $owner = $up->{owner} and last; | ||||
| 9169 | 7 | 12 | $up = $up->{up}; | ||||
| 9170 | } | ||||||
| 9171 | 107 | 302 | $owner ||= $zone->{owner}; | ||||
| 9172 | 107 | 157 | $owner and $aggregate->{owner} = $owner; | ||||
| 9173 | |||||||
| 9174 | 107 | 139 | link_aggregate_to_zone($aggregate, $zone, $key); | ||||
| 9175 | 107 | 138 | add_managed_hosts_to_aggregate($aggregate); | ||||
| 9176 | 107 | 164 | return; | ||||
| 9177 | } | ||||||
| 9178 | |||||||
| 9179 | ############################################################################## | ||||||
| 9180 | # Purpose : Process all explicitly defined aggregates. Check proper usage of | ||||||
| 9181 | # aggregates. For every aggregate, link aggregate objects to all | ||||||
| 9182 | # zones inside the zone cluster containing the aggregates link | ||||||
| 9183 | # network and set aggregate and zone properties. Add aggregate | ||||||
| 9184 | # objects to global @networks array. | ||||||
| 9185 | # Comments : Has to be called after zones have been set up. But before | ||||||
| 9186 | # find_subnets_in_zone calculates {up} and {networks} relation. | ||||||
| 9187 | sub link_aggregates { | ||||||
| 9188 | |||||||
| 9189 | 337 | 0 | 279 | my @aggregates_in_cluster; # Collect all aggregates inside clusters | |||
| 9190 | |||||||
| 9191 | |||||||
| 9192 | 337 | 631 | for my $name (sort keys %aggregates) { | ||||
| 9193 | 52 | 70 | my $aggregate = $aggregates{$name}; | ||||
| 9194 | 52 52 | 50 102 | my ($type, $name) = @{ delete($aggregate->{link}) }; | ||||
| 9195 | 52 | 73 | my $err; | ||||
| 9196 | my $router; | ||||||
| 9197 | |||||||
| 9198 | # Assure aggregates to be linked to networks only | ||||||
| 9199 | 52 | 112 | if ($type ne 'network') { | ||||
| 9200 | 1 | 5 | err_msg("$aggregate->{name} must not be linked to $type:$name"); | ||||
| 9201 | 1 | 1 | $aggregate->{disabled} = 1; | ||||
| 9202 | 1 | 3 | next; | ||||
| 9203 | } | ||||||
| 9204 | |||||||
| 9205 | # Assure aggregate link to exist/disable aggregates without active links | ||||||
| 9206 | 51 | 62 | my $network = $networks{$name}; | ||||
| 9207 | 51 | 91 | if (not $network) { | ||||
| 9208 | 0 | 0 | err_msg("Referencing undefined $type:$name", | ||||
| 9209 | " from $aggregate->{name}"); | ||||||
| 9210 | 0 | 0 | $aggregate->{disabled} = 1; | ||||
| 9211 | 0 | 0 | next; | ||||
| 9212 | } | ||||||
| 9213 | 51 | 114 | if ($network->{disabled}) { | ||||
| 9214 | 1 | 2 | $aggregate->{disabled} = 1; | ||||
| 9215 | 1 | 2 | next; | ||||
| 9216 | } | ||||||
| 9217 | |||||||
| 9218 | # Reference network link in security zone. | ||||||
| 9219 | 50 | 52 | my $zone = $network->{zone}; | ||||
| 9220 | 50 | 60 | $zone->{link} = $network; # only used in cut-netspoc | ||||
| 9221 | |||||||
| 9222 | # Assure aggregate and network private status to be equal | ||||||
| 9223 | 50 | 147 | my $private1 = $aggregate->{private} || 'public'; | ||||
| 9224 | 50 | 50 | my $private2 = $network->{private}; | ||||
| 9225 | 50 | 142 | $private2 ||= 'public'; | ||||
| 9226 | 50 | 84 | $private1 eq $private2 | ||||
| 9227 | or err_msg("$private1 $aggregate->{name} must not be linked", | ||||||
| 9228 | " to $private2 $type:$name"); | ||||||
| 9229 | |||||||
| 9230 | # Assure that no other aggregate with same IP and mask exists in cluster | ||||||
| 9231 | 50 50 | 48 88 | my ($ip, $mask) = @{$aggregate}{qw(ip mask)}; | ||||
| 9232 | 50 | 111 | my $key = "$ip/$mask"; | ||||
| 9233 | 50 | 51 | my $cluster = $zone->{zone_cluster}; | ||||
| 9234 | 50 | 97 | for my $zone2 ($cluster ? @$cluster : ($zone)) { | ||||
| 9235 | 55 | 157 | if (my $other = $zone2->{ipmask2aggregate}->{$key}) { | ||||
| 9236 | 1 | 5 | err_msg("Duplicate $other->{name} and $aggregate->{name}", | ||||
| 9237 | " in $zone->{name}"); | ||||||
| 9238 | } | ||||||
| 9239 | } | ||||||
| 9240 | |||||||
| 9241 | # Collect aggregates inside clusters | ||||||
| 9242 | 50 | 94 | if ($cluster) { | ||||
| 9243 | 4 | 5 | push(@aggregates_in_cluster, $aggregate); | ||||
| 9244 | } | ||||||
| 9245 | |||||||
| 9246 | # Use aggregate with ip 0/0 to set attributes of all zones in cluster. | ||||||
| 9247 | # | ||||||
| 9248 | # Even NAT is moved to zone for aggregate 0/0 although we | ||||||
| 9249 | # retain NAT at other aggregates. | ||||||
| 9250 | # This is an optimization to prevent the creation of many aggregates 0/0 | ||||||
| 9251 | # if only inheritance of NAT from area to network is needed. | ||||||
| 9252 | 50 | 90 | if ($mask == 0) { | ||||
| 9253 | 29 | 38 | for my $attr (qw(has_unenforceable owner nat)) { | ||||
| 9254 | 87 | 173 | if (my $v = delete $aggregate->{$attr}) { | ||||
| 9255 | 16 | 31 | for my $zone2 ($cluster ? @$cluster : ($zone)) { | ||||
| 9256 | 17 | 44 | $zone2->{$attr} = $v; | ||||
| 9257 | } | ||||||
| 9258 | } | ||||||
| 9259 | } | ||||||
| 9260 | } | ||||||
| 9261 | # Link aggragate and zone (also setting zone{ipmask2aggregate} | ||||||
| 9262 | 50 | 87 | link_aggregate_to_zone($aggregate, $zone, $key); | ||||
| 9263 | } | ||||||
| 9264 | |||||||
| 9265 | # add aggregate to all zones in the zone cluster | ||||||
| 9266 | 337 | 416 | for my $aggregate (@aggregates_in_cluster) { | ||||
| 9267 | 4 | 6 | duplicate_aggregate_to_cluster($aggregate); | ||||
| 9268 | } | ||||||
| 9269 | 337 | 305 | return; | ||||
| 9270 | } | ||||||
| 9271 | ############################################################################## | ||||||
| 9272 | # Parameter: $aggregate object reference, $implicit flag | ||||||
| 9273 | # Purpose : Create an aggregate object for every zone inside the zones cluster | ||||||
| 9274 | # containing the aggregates link-network. | ||||||
| 9275 | # Comments : From users point of view, an aggregate refers to networks of a zone | ||||||
| 9276 | # cluster. Internally, an aggregate object represents a set of | ||||||
| 9277 | # networks inside a zone. Therefeore, every zone inside a cluster | ||||||
| 9278 | # gets its own copy of the defined aggregate to collect the zones | ||||||
| 9279 | # networks matching the aggregates IP address. | ||||||
| 9280 | # TDOD : Aggregate may be a non aggregate network, | ||||||
| 9281 | # e.g. a network with ip/mask 0/0. ?? | ||||||
| 9282 | sub duplicate_aggregate_to_cluster { | ||||||
| 9283 | 10 | 0 | 11 | my ($aggregate, $implicit) = @_; | |||
| 9284 | 10 | 14 | my $cluster = $aggregate->{zone}->{zone_cluster}; | ||||
| 9285 | 10 10 | 8 16 | my ($ip, $mask) = @{$aggregate}{qw(ip mask)}; | ||||
| 9286 | 10 | 18 | my $key = "$ip/$mask"; | ||||
| 9287 | |||||||
| 9288 | # Process every zone of the zone cluster | ||||||
| 9289 | 10 | 13 | for my $zone (@$cluster) { | ||||
| 9290 | 24 | 50 | next if $zone->{ipmask2aggregate}->{$key}; | ||||
| 9291 | # debug("Dupl. $aggregate->{name} to $zone->{name}"); | ||||||
| 9292 | |||||||
| 9293 | # Create new aggregate object for every zone inside the cluster | ||||||
| 9294 | 12 | 24 | my $aggregate2 = new( | ||||
| 9295 | 'Network', | ||||||
| 9296 | name => $aggregate->{name}, | ||||||
| 9297 | is_aggregate => 1, | ||||||
| 9298 | ip => $aggregate->{ip}, | ||||||
| 9299 | mask => $aggregate->{mask}, | ||||||
| 9300 | ); | ||||||
| 9301 | |||||||
| 9302 | # Link new aggregate object and cluster | ||||||
| 9303 | 12 | 16 | if ($implicit) { | ||||
| 9304 | 9 | 12 | link_implicit_aggregate_to_zone($aggregate2, $zone, $key); | ||||
| 9305 | } | ||||||
| 9306 | else { | ||||||
| 9307 | 3 | 4 | link_aggregate_to_zone($aggregate2, $zone, $key); | ||||
| 9308 | } | ||||||
| 9309 | } | ||||||
| 9310 | 10 | 15 | return; | ||||
| 9311 | } | ||||||
| 9312 | |||||||
| 9313 | ############################################################################### | ||||||
| 9314 | # Find aggregate referenced from any:[..]. | ||||||
| 9315 | # Creates new anonymous aggregate if missing. | ||||||
| 9316 | # If zone is part of a zone_cluster, | ||||||
| 9317 | # return aggregates for each zone of the cluster. | ||||||
| 9318 | sub get_any { | ||||||
| 9319 | 184 | 0 | 188 | my ($zone, $ip, $mask) = @_; | |||
| 9320 | 184 | 330 | my $key = "$ip/$mask"; | ||||
| 9321 | 184 | 170 | my $cluster = $zone->{zone_cluster}; | ||||
| 9322 | 184 | 330 | if (!$zone->{ipmask2aggregate}->{$key}) { | ||||
| 9323 | |||||||
| 9324 | # Check, if there is a network with same IP as the requested | ||||||
| 9325 | # aggregate. If found, don't create a new aggregate in zone, | ||||||
| 9326 | # but use the network instead. Otherwise {up} relation | ||||||
| 9327 | # wouldn't be well defined. | ||||||
| 9328 | 99 127 108 | 149 417 210 | if (my @networks = grep({ $_->{mask} == $mask && $_->{ip} == $ip } | ||||
| 9329 | 108 | 83 | map { @{ $_->{networks} } } | ||||
| 9330 | $cluster ? @$cluster : ($zone))) | ||||||
| 9331 | { | ||||||
| 9332 | 1 | 3 | @networks > 1 and internal_err; | ||||
| 9333 | 1 | 2 | my ($network) = @networks; | ||||
| 9334 | 1 | 1 | my $zone2 = $network->{zone}; | ||||
| 9335 | |||||||
| 9336 | # Handle $network like an aggregate. | ||||||
| 9337 | 1 | 2 | $zone2->{ipmask2aggregate}->{$key} = $network; | ||||
| 9338 | |||||||
| 9339 | # Create aggregates in cluster, using the name of the network. | ||||||
| 9340 | 1 | 2 | duplicate_aggregate_to_cluster($network, 1) if $cluster; | ||||
| 9341 | } | ||||||
| 9342 | else { | ||||||
| 9343 | |||||||
| 9344 | # any:[network:x] => any:[ip=i.i.i.i/pp & network:x] | ||||||
| 9345 | 98 | 135 | my $p_ip = print_ip($ip); | ||||
| 9346 | 98 | 136 | my $prefix = mask2prefix($mask); | ||||
| 9347 | 98 | 111 | my $name = $zone->{name}; | ||||
| 9348 | 98 | 365 | $name =~ s/\[/[ip=$p_ip\/$prefix & / if $prefix != 0; | ||||
| 9349 | 98 | 153 | my $aggregate = new( | ||||
| 9350 | 'Network', | ||||||
| 9351 | name => $name, | ||||||
| 9352 | is_aggregate => 1, | ||||||
| 9353 | ip => $ip, | ||||||
| 9354 | mask => $mask, | ||||||
| 9355 | ); | ||||||
| 9356 | 98 | 175 | if (my $private = $zone->{private}) { | ||||
| 9357 | 0 | 0 | $aggregate->{private} = $private; | ||||
| 9358 | } | ||||||
| 9359 | 98 | 150 | link_implicit_aggregate_to_zone($aggregate, $zone, $key); | ||||
| 9360 | 98 | 207 | duplicate_aggregate_to_cluster($aggregate, 1) if $cluster; | ||||
| 9361 | }; | ||||||
| 9362 | } | ||||||
| 9363 | 184 | 239 | if ($cluster) { | ||||
| 9364 | 12 | 79 | return get_cluster_aggregates($zone, $ip, $mask); | ||||
| 9365 | } | ||||||
| 9366 | else { | ||||||
| 9367 | 172 | 529 | return $zone->{ipmask2aggregate}->{$key}; | ||||
| 9368 | } | ||||||
| 9369 | } | ||||||
| 9370 | |||||||
| 9371 | # Get set of aggregates of a zone cluster. | ||||||
| 9372 | # Ignore zone having no aggregate from unnumbered network. | ||||||
| 9373 | sub get_cluster_aggregates { | ||||||
| 9374 | 12 | 0 | 15 | my ($zone, $ip, $mask) = @_; | |||
| 9375 | 12 | 20 | my $key = "$ip/$mask"; | ||||
| 9376 | return | ||||||
| 9377 | 12 32 12 | 8 108 17 | map { $_->{ipmask2aggregate}->{$key}||() } @{ $zone->{zone_cluster} }; | ||||
| 9378 | } | ||||||
| 9379 | |||||||
| 9380 | ############################################################################### | ||||||
| 9381 | # Purpose : Collects all elements (networks, unmanaged routers, interfaces) of | ||||||
| 9382 | # a zone object and references the zone in its elements. Sets zone | ||||||
| 9383 | # property flags and private status. | ||||||
| 9384 | # Comments : Unnumbered and tunnel networks are not referenced in zone objects, | ||||||
| 9385 | # as they are no valid src or dst. | ||||||
| 9386 | sub set_zone1 { | ||||||
| 9387 | 1148 | 0 | 1094 | my ($network, $zone, $in_interface) = @_; | |||
| 9388 | |||||||
| 9389 | # Return if network was processed already (= loop was found). | ||||||
| 9390 | 1148 | 1749 | if ($network->{zone}) { | ||||
| 9391 | 36 | 61 | return; | ||||
| 9392 | } | ||||||
| 9393 | |||||||
| 9394 | # Reference zone in network and vice versa... | ||||||
| 9395 | 1112 | 1185 | $network->{zone} = $zone; | ||||
| 9396 | 1112 | 2646 | if (not($network->{ip} =~ /^(?:unnumbered|tunnel)$/)) {# no valid src/dst | ||||
| 9397 | 1076 1076 | 787 1492 | push @{ $zone->{networks} }, $network; | ||||
| 9398 | } | ||||||
| 9399 | # debug("$network->{name} in $zone->{name}"); | ||||||
| 9400 | |||||||
| 9401 | # Set zone property flags depending on network properties... | ||||||
| 9402 | 1112 | 1904 | $network->{ip} eq 'tunnel' and $zone->{is_tunnel} = 1; | ||||
| 9403 | 1112 | 1578 | $network->{has_id_hosts} and $zone->{has_id_hosts} = 1; | ||||
| 9404 | |||||||
| 9405 | # Check network 'private' status and zone 'private' status to be equal. | ||||||
| 9406 | 1112 | 2796 | my $private1 = $network->{private} || 'public'; | ||||
| 9407 | 1112 | 1546 | if ($zone->{private}) { | ||||
| 9408 | 230 | 196 | my $private2 = $zone->{private}; | ||||
| 9409 | 230 | 432 | if ($private1 ne $private2) { | ||||
| 9410 | 1 | 1 | my $other = $zone->{networks}->[0]; | ||||
| 9411 | 1 | 8 | err_msg("All networks of $zone->{name} must have", | ||||
| 9412 | " identical 'private' status\n", | ||||||
| 9413 | " - $other->{name}: $private2\n", | ||||||
| 9414 | " - $network->{name}: $private1"); | ||||||
| 9415 | } | ||||||
| 9416 | } | ||||||
| 9417 | |||||||
| 9418 | # Set zone private status (attribute will be removed if value is 'public') | ||||||
| 9419 | 1112 | 1122 | $zone->{private} = $private1;# TODO: is set in every iteration. else clause? | ||||
| 9420 | |||||||
| 9421 | # Proceed with adjacent elements... | ||||||
| 9422 | 1112 1112 | 836 1391 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 9423 | 1630 | 3067 | next if $interface eq $in_interface; # Ignore Interface we came from. | ||||
| 9424 | 1400 | 1237 | my $router = $interface->{router}; | ||||
| 9425 | |||||||
| 9426 | # If its a zone delimiting router, reference interface in zone and v.v. | ||||||
| 9427 | 1400 | 2907 | if ($router->{managed} or $router->{semi_managed}) { | ||||
| 9428 | 1158 | 1164 | $interface->{zone} = $zone; | ||||
| 9429 | 1158 1158 | 804 2365 | push @{ $zone->{interfaces} }, $interface; | ||||
| 9430 | } | ||||||
| 9431 | else { | ||||||
| 9432 | |||||||
| 9433 | #If its an unmanaged router, reference router in zone and v.v. | ||||||
| 9434 | 242 | 391 | next if $router->{zone}; # Traverse each unmanaged router only once. | ||||
| 9435 | 206 | 223 | $router->{zone} = $zone; # added only to prevent double traversal | ||||
| 9436 | 206 206 | 163 280 | push @{ $zone->{unmanaged_routers} }, $router; | ||||
| 9437 | |||||||
| 9438 | # Recursively add adjacent networks. | ||||||
| 9439 | 206 206 | 179 257 | for my $out_interface (@{ $router->{interfaces} }) { | ||||
| 9440 | 472 | 1009 | next if $out_interface eq $interface;# Ignore IF we came from. | ||||
| 9441 | 266 | 400 | next if $out_interface->{disabled}; | ||||
| 9442 | 266 | 497 | set_zone1($out_interface->{network}, $zone, $out_interface); | ||||
| 9443 | } | ||||||
| 9444 | } | ||||||
| 9445 | } | ||||||
| 9446 | 1112 | 1514 | return; | ||||
| 9447 | } | ||||||
| 9448 | |||||||
| 9449 | ############################################################################## | ||||||
| 9450 | # Purpose : Collect zones connected by semi_managed devices into a cluster. | ||||||
| 9451 | # Comments : Tunnel_zones are not included in zone clusters, because | ||||||
| 9452 | # - it is useless in rules and | ||||||
| 9453 | # - we would get inconsistent owner since zone of tunnel | ||||||
| 9454 | # doesn't inherit from area. | ||||||
| 9455 | sub set_zone_cluster { | ||||||
| 9456 | 882 | 0 | 825 | my ($zone, $in_interface, $zone_aref) = @_; | |||
| 9457 | |||||||
| 9458 | # Reference zone in cluster object and vice versa | ||||||
| 9459 | 882 | 1586 | push @$zone_aref, $zone if !$zone->{is_tunnel}; | ||||
| 9460 | 882 | 846 | $zone->{zone_cluster} = $zone_aref; | ||||
| 9461 | |||||||
| 9462 | 882 | 2068 | my $private1 = $zone->{private} || 'public'; | ||||
| 9463 | |||||||
| 9464 | # Find zone interfaces connected to semi-managed routers... | ||||||
| 9465 | 882 882 | 665 1097 | for my $interface (@{ $zone->{interfaces} }) { | ||||
| 9466 | 1158 | 1999 | next if $interface eq $in_interface; | ||||
| 9467 | 1132 | 1579 | next if $interface->{main_interface}; | ||||
| 9468 | 1075 | 929 | my $router = $interface->{router}; | ||||
| 9469 | 1075 | 2148 | next if $router->{managed}; | ||||
| 9470 | 19 | 33 | next if $router->{active_path}; | ||||
| 9471 | 19 | 28 | local $router->{active_path} = 1; | ||||
| 9472 | |||||||
| 9473 | # Process adjacent zones... | ||||||
| 9474 | 19 19 | 18 25 | for my $out_interface (@{ $router->{interfaces} }) { | ||||
| 9475 | 46 | 96 | next if $out_interface eq $interface; | ||||
| 9476 | 27 | 25 | my $next = $out_interface->{zone}; | ||||
| 9477 | 27 | 46 | next if $next->{zone_cluster}; #traverse zones only once | ||||
| 9478 | 26 | 45 | next if $out_interface->{main_interface}; | ||||
| 9479 | |||||||
| 9480 | # Check for equal private status. | ||||||
| 9481 | 26 | 68 | my $private2 = $next->{private} || 'public'; | ||||
| 9482 | 26 | 39 | $private1 eq $private2 or | ||||
| 9483 | err_msg("Zones connected by $router->{name}", | ||||||
| 9484 | " must all have identical 'private' status\n", | ||||||
| 9485 | " - $zone->{name}: $private1\n", | ||||||
| 9486 | " - $next->{name}: $private2"); | ||||||
| 9487 | |||||||
| 9488 | # Add adjacent zone recursively. | ||||||
| 9489 | 26 | 52 | set_zone_cluster($next, $out_interface, $zone_aref); | ||||
| 9490 | } | ||||||
| 9491 | } | ||||||
| 9492 | 882 | 1009 | return; | ||||
| 9493 | } | ||||||
| 9494 | |||||||
| 9495 | # Two zones are zone_eq, if | ||||||
| 9496 | # - zones are equal or | ||||||
| 9497 | # - both belong to the same zone cluster. | ||||||
| 9498 | sub zone_eq { | ||||||
| 9499 | 12 | 0 | 16 | my ($zone1, $zone2) = @_; | |||
| 9500 | 12 | 97 | return(($zone1->{zone_cluster} || $zone1) eq | ||||
| 9501 | ($zone2->{zone_cluster} || $zone2)); | ||||||
| 9502 | } | ||||||
| 9503 | |||||||
| 9504 | ############################################################################### | ||||||
| 9505 | # Purpose : Collect zones and managed routers of an area object and set a | ||||||
| 9506 | # reference to the area in its zones and routers. | ||||||
| 9507 | # For areas with defined borders: Keep track of area borders found | ||||||
| 9508 | # during area traversal. | ||||||
| 9509 | # For anchor/auto_border areas: fill {border} and {inclusive_border} | ||||||
| 9510 | # arrays. | ||||||
| 9511 | # Returns : undef (or aref of interfaces, if invalid path was found). | ||||||
| 9512 | sub set_area1 { | ||||||
| 9513 | 186 | 0 | 179 | my ($obj, $area, $in_interface) = @_; | |||
| 9514 | |||||||
| 9515 | 186 | 376 | return if $obj->{areas}->{$area}; # Found a loop. | ||||
| 9516 | |||||||
| 9517 | 182 | 272 | $obj->{areas}->{$area} = $area;# Find duplicate/overlapping areas or loops | ||||
| 9518 | |||||||
| 9519 | 182 | 219 | my $is_zone = is_zone($obj); | ||||
| 9520 | |||||||
| 9521 | # Reference zones and managed routers in the corresponding area | ||||||
| 9522 | 182 | 336 | if ($is_zone) { | ||||
| 9523 | 125 | 184 | if (!$obj->{is_tunnel}) { | ||||
| 9524 | 125 125 | 91 164 | push @{ $area->{zones} }, $obj; | ||||
| 9525 | } | ||||||
| 9526 | } | ||||||
| 9527 | elsif ($obj->{managed} || $obj->{routing_only}) { | ||||||
| 9528 | 57 57 | 46 83 | push @{ $area->{managed_routers} }, $obj; | ||||
| 9529 | } | ||||||
| 9530 | |||||||
| 9531 | 182 | 177 | my $auto_border = $area->{auto_border}; | ||||
| 9532 | 182 | 154 | my $lookup = $area->{intf_lookup}; | ||||
| 9533 | |||||||
| 9534 | 182 182 | 136 220 | for my $interface (@{ $obj->{interfaces} }) { | ||||
| 9535 | |||||||
| 9536 | # Ignore interface we came from. | ||||||
| 9537 | 301 | 641 | next if $interface eq $in_interface; | ||||
| 9538 | |||||||
| 9539 | # No further traversal at secondary interfaces | ||||||
| 9540 | 139 | 209 | next if $interface->{main_interface}; | ||||
| 9541 | |||||||
| 9542 | # For areas with defined borders, check if border was found... | ||||||
| 9543 | 135 | 287 | if ($lookup->{$interface}) { | ||||
| 9544 | 13 | 12 | my $is_inclusive = $interface->{is_inclusive}; | ||||
| 9545 | |||||||
| 9546 | # Reached border from wrong side or border classification wrong. | ||||||
| 9547 | 13 | 59 | if ($is_inclusive->{$area} xor !$is_zone) { | ||||
| 9548 | 2 | 7 | return [ $interface ]; # will be collected to show invalid path | ||||
| 9549 | } | ||||||
| 9550 | |||||||
| 9551 | # ...mark found border in lookup hash. | ||||||
| 9552 | 11 | 19 | $lookup->{$interface} = 'found'; | ||||
| 9553 | 11 | 16 | next; | ||||
| 9554 | } | ||||||
| 9555 | |||||||
| 9556 | # For auto_border areas, just collect border/inclusive_border interface | ||||||
| 9557 | elsif ($auto_border) { | ||||||
| 9558 | 6 | 9 | if ($interface->{is_border}) { | ||||
| 9559 | 2 2 | 2 4 | push(@{ $area->{$is_zone ? 'border' : 'inclusive_border'} }, | ||||
| 9560 | $interface); | ||||||
| 9561 | 2 | 3 | next; | ||||
| 9562 | } | ||||||
| 9563 | } | ||||||
| 9564 | |||||||
| 9565 | # Proceed traversal with next element | ||||||
| 9566 | 120 | 166 | my $next = $interface->{$is_zone ? 'router' : 'zone'}; | ||||
| 9567 | 120 | 212 | if (my $err_path = set_area1($next, $area, $interface)) { | ||||
| 9568 | 3 | 4 | push @$err_path, $interface; # collect interfaces of invalid path | ||||
| 9569 | 3 | 7 | return $err_path; | ||||
| 9570 | } | ||||||
| 9571 | } | ||||||
| 9572 | 177 | 449 | return; | ||||
| 9573 | } | ||||||
| 9574 | |||||||
| 9575 | ############################################################################### | ||||||
| 9576 | # Purpose : Distribute router_attributes from the area definition to the managed | ||||||
| 9577 | # routers of the area. | ||||||
| 9578 | sub inherit_router_attributes { | ||||||
| 9579 | 66 | 0 | 64 | my ($area) = @_; | |||
| 9580 | |||||||
| 9581 | # Check for attributes to be inherited. | ||||||
| 9582 | 66 | 126 | my $attributes = $area->{router_attributes} or return; | ||||
| 9583 | 7 | 14 | $attributes->{owner} and keys %$attributes == 1 and return; # handled later | ||||
| 9584 | |||||||
| 9585 | #Process all managed routers of the area inherited from. | ||||||
| 9586 | 7 7 | 7 10 | for my $router (@{ $area->{managed_routers} }) { | ||||
| 9587 | 6 | 12 | for my $key (keys %$attributes) { | ||||
| 9588 | |||||||
| 9589 | 12 | 19 | next if $key eq 'owner'; # Owner is handled in propagate_owners. | ||||
| 9590 | |||||||
| 9591 | # if attribute exists in router (router or smaller area definition) | ||||||
| 9592 | 12 | 11 | my $val = $attributes->{$key}; | ||||
| 9593 | 12 | 17 | if (my $r_val = $router->{$key}) { | ||||
| 9594 | 8 | 37 | if ( $r_val eq $val # warn, if attributes are equal | ||||
| 9595 | || ref $r_val eq 'ARRAY' && ref $val eq 'ARRAY' | ||||||
| 9596 | && aref_eq($r_val, $val)) | ||||||
| 9597 | { | ||||||
| 9598 | 1 | 6 | warn_msg( | ||||
| 9599 | "Useless attribute '$key' at $router->{name},\n", | ||||||
| 9600 | " it was already inherited from $attributes->{name}"); | ||||||
| 9601 | } | ||||||
| 9602 | } | ||||||
| 9603 | |||||||
| 9604 | # Add attribute to the router object if not yet set. | ||||||
| 9605 | else { | ||||||
| 9606 | 4 | 10 | $router->{$key} = $val; | ||||
| 9607 | } | ||||||
| 9608 | } | ||||||
| 9609 | } | ||||||
| 9610 | 7 | 8 | return; | ||||
| 9611 | } | ||||||
| 9612 | |||||||
| 9613 | ############################################################################### | ||||||
| 9614 | # Purpose : Returns true if nat hashes are equal. | ||||||
| 9615 | sub nat_equal { | ||||||
| 9616 | 23 | 0 | 22 | my ($nat1, $nat2) = @_; | |||
| 9617 | |||||||
| 9618 | # Check whether nat attributes are different... | ||||||
| 9619 | 23 | 26 | for my $attr (qw(ip mask dynamic hidden identity)) { | ||||
| 9620 | 50 | 184 | return if defined $nat1->{$attr} xor defined $nat2->{$attr}; | ||||
| 9621 | 37 | 61 | next if !defined $nat1->{$attr};# none of the Nats holds the attribute | ||||
| 9622 | 20 | 49 | return if $nat1->{$attr} ne $nat2->{$attr};# values of attribute differ | ||||
| 9623 | } | ||||||
| 9624 | |||||||
| 9625 | # ...return true if no difference found. | ||||||
| 9626 | 3 | 7 | return 1; | ||||
| 9627 | } | ||||||
| 9628 | ############################################################################## | ||||||
| 9629 | # Purpose : 1. Generate warning if NAT value of two objects hold the same | ||||||
| 9630 | # attributes. | ||||||
| 9631 | # 2. Mark occurence of identity NAT that masks inheritance. | ||||||
| 9632 | # This is used later to warn on useless identity NAT. | ||||||
| 9633 | sub check_useless_nat { | ||||||
| 9634 | 23 | 0 | 29 | my ($nat_tag, $nat1, $nat2, $obj1, $obj2) = @_; | |||
| 9635 | 23 | 30 | if (nat_equal($nat1, $nat2)) { | ||||
| 9636 | 3 | 12 | warn_msg("Useless nat:$nat_tag at $obj2->{name},\n", | ||||
| 9637 | " it is already inherited from $obj1->{name}"); | ||||||
| 9638 | } | ||||||
| 9639 | 23 | 35 | if ($nat2->{identity}) { | ||||
| 9640 | 10 | 12 | $nat2->{is_used} = 1; | ||||
| 9641 | } | ||||||
| 9642 | 23 | 36 | return; | ||||
| 9643 | } | ||||||
| 9644 | |||||||
| 9645 | ############################################################################## | ||||||
| 9646 | # Purpose : Distribute NAT from area to zones. | ||||||
| 9647 | sub inherit_area_nat { | ||||||
| 9648 | |||||||
| 9649 | 66 | 0 | 67 | my ($area) = @_; | |||
| 9650 | 66 | 154 | my $hash = $area->{nat} or return; | ||||
| 9651 | |||||||
| 9652 | # Process every nat definition of area. | ||||||
| 9653 | 5 | 10 | for my $nat_tag (sort keys %$hash) { | ||||
| 9654 | 6 | 7 | my $nat = $hash->{$nat_tag}; | ||||
| 9655 | |||||||
| 9656 | # Distribute nat definitions to every zone of area. | ||||||
| 9657 | 6 6 | 7 8 | for my $zone (@{ $area->{zones} }) { | ||||
| 9658 | |||||||
| 9659 | # Skip zone, if NAT tag exists in zone already... | ||||||
| 9660 | 10 | 17 | if (my $z_nat = $zone->{nat}->{$nat_tag}) { | ||||
| 9661 | |||||||
| 9662 | # ... and warn if zones NAT value holds the same attributes. | ||||||
| 9663 | 4 | 7 | check_useless_nat($nat_tag, $nat, $z_nat, $area, $zone); | ||||
| 9664 | 4 | 8 | next; | ||||
| 9665 | } | ||||||
| 9666 | |||||||
| 9667 | # Store NAT definition in zone otherwise | ||||||
| 9668 | 6 | 14 | $zone->{nat}->{$nat_tag} = $nat; | ||||
| 9669 | # debug "$zone->{name}: $nat_tag from $area->{name}"; | ||||||
| 9670 | } | ||||||
| 9671 | } | ||||||
| 9672 | 5 | 8 | return; | ||||
| 9673 | } | ||||||
| 9674 | |||||||
| 9675 | ############################################################################### | ||||||
| 9676 | # Purpose : Assure that areas are processed in the right order and distribute | ||||||
| 9677 | # area attributes to zones and managed routers. | ||||||
| 9678 | sub inherit_attributes_from_area { | ||||||
| 9679 | |||||||
| 9680 | # Areas can be nested. Proceed from small to larger ones. | ||||||
| 9681 | 337 29 29 29 | 0 | 556 24 34 43 | for my $area (sort { @{ $a->{zones} } <=> @{ $b->{zones} } } @areas) { | |||
| 9682 | 66 | 95 | inherit_router_attributes($area); | ||||
| 9683 | 66 | 90 | inherit_area_nat($area); | ||||
| 9684 | } | ||||||
| 9685 | 337 | 323 | return; | ||||
| 9686 | } | ||||||
| 9687 | |||||||
| 9688 | ############################################################################### | ||||||
| 9689 | # Purpose : Distributes NAT from aggregates and networks to other networks | ||||||
| 9690 | # in same zone, that are in subnet relation. | ||||||
| 9691 | # If a network A is subnet of multiple networks B < C, | ||||||
| 9692 | # then NAT of B is used. | ||||||
| 9693 | sub inherit_nat_to_subnets_in_zone { | ||||||
| 9694 | 106 | 0 | 113 | my ($net_or_zone, $zone) = @_; | |||
| 9695 | 97 | 148 | my ($ip1, $mask1) = is_network($net_or_zone) | ||||
| 9696 | 106 | 131 | ? @{$net_or_zone}{qw(ip mask)} | ||||
| 9697 | : (0, 0); | ||||||
| 9698 | 106 | 129 | my $hash = $net_or_zone->{nat}; | ||||
| 9699 | 106 | 215 | for my $nat_tag (sort keys %$hash) { | ||||
| 9700 | 136 | 159 | my $nat = $hash->{$nat_tag}; | ||||
| 9701 | # debug "inherit $nat_tag from $net_or_zone->{name}"; | ||||||
| 9702 | |||||||
| 9703 | # Distribute nat definitions to every subnet of supernet, aggregate or zone. | ||||||
| 9704 | 136 136 | 98 175 | for my $network (@{ $zone->{networks} }) { | ||||
| 9705 | 248 248 | 174 294 | my ($ip2, $mask2) = @{$network}{qw(ip mask)}; | ||||
| 9706 | |||||||
| 9707 | # Only process subnets. | ||||||
| 9708 | 248 | 539 | $mask2 > $mask1 or next; | ||||
| 9709 | 55 | 73 | match_ip($ip2, $ip1, $mask1) or next; | ||||
| 9710 | |||||||
| 9711 | # Skip network, if NAT tag exists in network already... | ||||||
| 9712 | 33 | 90 | if (my $n_nat = $network->{nat}->{$nat_tag}) { | ||||
| 9713 | |||||||
| 9714 | # ... and warn if networks NAT value holds the | ||||||
| 9715 | # same attributes. | ||||||
| 9716 | 19 | 29 | check_useless_nat($nat_tag, $nat, $n_nat, $net_or_zone, $network); | ||||
| 9717 | } | ||||||
| 9718 | |||||||
| 9719 | elsif ($network->{ip} eq 'bridged' and not $nat->{identity}) { | ||||||
| 9720 | 0 | 0 | err_msg("Must not inherit nat:$nat_tag at bridged", | ||||
| 9721 | " $network->{name} from $net_or_zone->{name}"); | ||||||
| 9722 | } | ||||||
| 9723 | |||||||
| 9724 | # Copy NAT defintion; append name of network. | ||||||
| 9725 | else { | ||||||
| 9726 | 14 | 69 | my $sub_nat = { | ||||
| 9727 | %$nat, | ||||||
| 9728 | |||||||
| 9729 | # Needed for error messages. | ||||||
| 9730 | name => "nat:$nat_tag($network->{name})", | ||||||
| 9731 | }; | ||||||
| 9732 | |||||||
| 9733 | # For static NAT from net_or_zone, | ||||||
| 9734 | # - merge IP from supernet and subnet, | ||||||
| 9735 | # - adapt mask to size of subnet | ||||||
| 9736 | 14 | 33 | if (not $nat->{dynamic}) { | ||||
| 9737 | |||||||
| 9738 | # Take higher bits from NAT IP, lower bits from original IP. | ||||||
| 9739 | 2 | 3 | $sub_nat->{ip} |= $ip2 & complement_32bit($mask1); | ||||
| 9740 | 2 | 2 | $sub_nat->{mask} = $mask2; | ||||
| 9741 | } | ||||||
| 9742 | |||||||
| 9743 | 14 | 33 | $network->{nat}->{$nat_tag} = $sub_nat; | ||||
| 9744 | } | ||||||
| 9745 | } | ||||||
| 9746 | } | ||||||
| 9747 | 106 | 242 | return; | ||||
| 9748 | } | ||||||
| 9749 | |||||||
| 9750 | sub inherit_nat_in_zone { | ||||||
| 9751 | 337 | 0 | 367 | for my $zone (@zones) { | |||
| 9752 | |||||||
| 9753 | # Find all networks and aggregates of current zone, | ||||||
| 9754 | # that have NAT definitions. | ||||||
| 9755 | 1129 882 | 1503 917 | my @nat_supernets = grep({ $_->{nat} } | ||||
| 9756 | 882 | 1428 | @{ $zone->{networks} }, | ||||
| 9757 | 882 | 688 | values %{ $zone->{ipmask2aggregate} }); | ||||
| 9758 | |||||||
| 9759 | # Add zone object instead of aggregate 0/0, because NAT is stored | ||||||
| 9760 | # at zone in this case. | ||||||
| 9761 | 882 | 1223 | my @nat_zone = $zone->{nat} ? ($zone) : (); | ||||
| 9762 | |||||||
| 9763 | # Proceed from smaller to larger objects. (Bigger mask first.) | ||||||
| 9764 | 882 13 | 1683 23 | for my $supernet (sort({ $b->{mask} <=> $a->{mask} } @nat_supernets), | ||||
| 9765 | @nat_zone) | ||||||
| 9766 | { | ||||||
| 9767 | 106 | 142 | inherit_nat_to_subnets_in_zone($supernet, $zone); | ||||
| 9768 | } | ||||||
| 9769 | } | ||||||
| 9770 | 337 | 317 | return; | ||||
| 9771 | } | ||||||
| 9772 | |||||||
| 9773 | sub cleanup_after_inheritance { | ||||||
| 9774 | |||||||
| 9775 | # 1. Remove NAT entries from aggregates. | ||||||
| 9776 | # These are only used during NAT inheritance. | ||||||
| 9777 | # 2. Remove identity NAT entries. | ||||||
| 9778 | # These are only needed during NAT inheritance. | ||||||
| 9779 | 337 | 0 | 378 | for my $network (@networks) { | |||
| 9780 | 1165 | 1944 | my $href = $network->{nat} or next; | ||||
| 9781 | 111 | 166 | if ($network->{is_aggregate}) { | ||||
| 9782 | 2 | 2 | delete $network->{nat}; | ||||
| 9783 | 2 | 5 | next; | ||||
| 9784 | } | ||||||
| 9785 | 109 | 166 | for my $nat_tag (keys %$href) { | ||||
| 9786 | 138 | 135 | my $nat_network = $href->{$nat_tag}; | ||||
| 9787 | 138 | 330 | $nat_network->{identity} or next; | ||||
| 9788 | 10 | 13 | delete $href->{$nat_tag}; | ||||
| 9789 | 10 | 33 | $nat_network->{is_used} or | ||||
| 9790 | warn_msg("Useless identity nat:$nat_tag at $network->{name}"); | ||||||
| 9791 | } | ||||||
| 9792 | } | ||||||
| 9793 | 337 | 304 | return; | ||||
| 9794 | } | ||||||
| 9795 | |||||||
| 9796 | sub inherit_attributes { | ||||||
| 9797 | 337 | 0 | 467 | inherit_attributes_from_area(); | |||
| 9798 | 337 | 452 | inherit_nat_in_zone(); | ||||
| 9799 | 337 | 421 | cleanup_after_inheritance(); | ||||
| 9800 | 337 | 275 | return; | ||||
| 9801 | } | ||||||
| 9802 | |||||||
| 9803 | ############################################################################## | ||||||
| 9804 | # Purpose : Create a new zone object for every network without a zone | ||||||
| 9805 | sub set_zones { | ||||||
| 9806 | |||||||
| 9807 | # Process networks without a zone | ||||||
| 9808 | 337 | 0 | 389 | for my $network (@networks) { | |||
| 9809 | 1112 | 1759 | next if $network->{zone}; | ||||
| 9810 | |||||||
| 9811 | # Create zone object with name of corresponding aggregate and ip 0/0. | ||||||
| 9812 | 882 | 1913 | my $name = "any:[$network->{name}]"; | ||||
| 9813 | 882 | 1507 | my $zone = new('Zone', name => $name, networks => []); | ||||
| 9814 | 882 | 857 | push @zones, $zone; | ||||
| 9815 | |||||||
| 9816 | # Collect zone elements... | ||||||
| 9817 | 882 | 1192 | set_zone1($network, $zone, 0); | ||||
| 9818 | |||||||
| 9819 | # Mark zone which consists only of a loopback network. | ||||||
| 9820 | 31 | 87 | $zone->{loopback} = 1 | ||||
| 9821 | 882 | 1600 | if $network->{loopback} && @{ $zone->{networks} } == 1; | ||||
| 9822 | |||||||
| 9823 | # Attribute {is_tunnel} is set only when zone has only tunnel networks. | ||||||
| 9824 | 882 882 | 682 1422 | if (@{ $zone->{networks} }) {# tunnel networks arent referenced in zone | ||||
| 9825 | 873 | 884 | delete $zone->{is_tunnel}; | ||||
| 9826 | } | ||||||
| 9827 | |||||||
| 9828 | # Remove zone reference from unmanaged routers (no longer needed). | ||||||
| 9829 | 882 | 1432 | if (my $unmanaged = $zone->{unmanaged_routers}) { | ||||
| 9830 | 156 | 380 | delete $_->{zone} for @$unmanaged; | ||||
| 9831 | } | ||||||
| 9832 | |||||||
| 9833 | # Remove private status, if 'public' | ||||||
| 9834 | 882 | 2768 | if ($zone->{private} && $zone->{private} eq 'public') { | ||||
| 9835 | 881 | 1396 | delete $zone->{private}; | ||||
| 9836 | } | ||||||
| 9837 | } | ||||||
| 9838 | 337 | 342 | return; | ||||
| 9839 | } | ||||||
| 9840 | |||||||
| 9841 | ############################################################################## | ||||||
| 9842 | # Purpose : Clusters zones connected by semi_managed routers. References of all | ||||||
| 9843 | # zones of a cluster are stored in the {zone_cluster} attribute of | ||||||
| 9844 | # the zones. | ||||||
| 9845 | # Comments : The {zone_cluster} attribute is only set if the cluster has more | ||||||
| 9846 | # than one element. | ||||||
| 9847 | sub cluster_zones { | ||||||
| 9848 | |||||||
| 9849 | # Process all unclustered zones. | ||||||
| 9850 | 337 | 0 | 385 | for my $zone (@zones) { | |||
| 9851 | 882 | 1335 | next if $zone->{zone_cluster}; | ||||
| 9852 | |||||||
| 9853 | # Create a new cluster and collect its zones | ||||||
| 9854 | 856 | 849 | my $cluster = []; | ||||
| 9855 | 856 | 1072 | set_zone_cluster($zone, 0, $cluster); | ||||
| 9856 | |||||||
| 9857 | # delete clusters containing a single network only | ||||||
| 9858 | 856 | 1930 | delete $zone->{zone_cluster} if 1 >= @$cluster; | ||||
| 9859 | |||||||
| 9860 | # debug('cluster: ', join(',',map($_->{name}, @{$zone->{zone_cluster}}))) | ||||||
| 9861 | # if $zone->{zone_cluster}; | ||||||
| 9862 | } | ||||||
| 9863 | 337 | 337 | return; | ||||
| 9864 | } | ||||||
| 9865 | |||||||
| 9866 | ############################################################################### | ||||||
| 9867 | # Purpose : Mark interfaces, which are border of some area, prepare consistency | ||||||
| 9868 | # check for attributes {border} and {inclusive_border}. | ||||||
| 9869 | # Comments : Area labeled interfaces are needed to locate auto_borders. | ||||||
| 9870 | sub prepare_area_borders { | ||||||
| 9871 | 337 | 0 | 282 | my %has_inclusive_borders; # collects all routers with inclusive border IF | |||
| 9872 | |||||||
| 9873 | # Identify all interfaces which are border of some area | ||||||
| 9874 | 337 | 391 | for my $area (@areas) { | ||||
| 9875 | 66 | 75 | for my $attribute (qw(border inclusive_border)) { | ||||
| 9876 | 132 | 317 | my $border = $area->{$attribute} or next; | ||||
| 9877 | 52 | 55 | for my $interface (@$border) { | ||||
| 9878 | |||||||
| 9879 | # Reference delimited area in the interfaces attributes | ||||||
| 9880 | 62 | 81 | $interface->{is_border} = $area; # used for auto borders | ||||
| 9881 | 62 | 159 | if ($attribute eq 'inclusive_border') { | ||||
| 9882 | 18 | 35 | $interface->{is_inclusive}->{$area} = $area; | ||||
| 9883 | |||||||
| 9884 | # Collect routers with inclusive border interface | ||||||
| 9885 | 18 | 18 | my $router = $interface->{router}; | ||||
| 9886 | 18 | 54 | $has_inclusive_borders{$router} = $router; | ||||
| 9887 | } | ||||||
| 9888 | } | ||||||
| 9889 | } | ||||||
| 9890 | } | ||||||
| 9891 | 337 | 406 | return \%has_inclusive_borders; | ||||
| 9892 | } | ||||||
| 9893 | |||||||
| 9894 | ############################################################################### | ||||||
| 9895 | # Purpose : Collect zones, routers (and interfaces, if no borders defined) | ||||||
| 9896 | # of an area. | ||||||
| 9897 | # Returns : undef (or 1, if error was shown) | ||||||
| 9898 | sub set_area { | ||||||
| 9899 | 66 | 0 | 72 | my ($obj, $area, $in_interface) = @_; | |||
| 9900 | 66 | 123 | if (my $err_path = set_area1($obj, $area, $in_interface)) { | ||||
| 9901 | |||||||
| 9902 | # Print error path, if errors occurred | ||||||
| 9903 | 2 | 4 | push @$err_path, $in_interface if $in_interface; | ||||
| 9904 | 2 | 2 | my $err_intf = $err_path->[0]; | ||||
| 9905 | 2 | 2 | my $is_inclusive = $err_intf->{is_inclusive}; | ||||
| 9906 | 2 | 6 | my $err_obj = $err_intf->{$is_inclusive->{$area} ? 'router' : 'zone'}; | ||||
| 9907 | 2 | 7 | my $in_loop = $err_obj->{areas}->{$area} ? ' in loop' : ''; | ||||
| 9908 | 7 | 20 | err_msg("Inconsistent definition of $area->{name}", $in_loop, ".\n", | ||||
| 9909 | " It is reached from outside via this path:\n", | ||||||
| 9910 | 2 | 7 | " - ", join("\n - ", map { $_->{name} } reverse @$err_path)); | ||||
| 9911 | 2 | 4 | return 1; | ||||
| 9912 | } | ||||||
| 9913 | 64 | 66 | return; | ||||
| 9914 | } | ||||||
| 9915 | |||||||
| 9916 | ###############################################################################s | ||||||
| 9917 | # Purpose : Set up area objects, assure proper border definitions. | ||||||
| 9918 | sub set_areas { | ||||||
| 9919 | 337 | 0 | 388 | for my $area (@areas) { | |||
| 9920 | 66 | 101 | $area->{zones} = []; | ||||
| 9921 | 66 | 115 | if (my $network = $area->{anchor}) { | ||||
| 9922 | 17 | 30 | set_area($network->{zone}, $area, 0); | ||||
| 9923 | } | ||||||
| 9924 | else { | ||||||
| 9925 | |||||||
| 9926 | # For efficient look up if some IF is a border of current area. | ||||||
| 9927 | 49 | 70 | my $lookup = $area->{intf_lookup} = {}; | ||||
| 9928 | |||||||
| 9929 | 49 | 46 | my $start; | ||||
| 9930 | my $obj1; | ||||||
| 9931 | |||||||
| 9932 | # Collect all area delimiting interfaces in border lookup array | ||||||
| 9933 | 49 | 53 | for my $attr (qw(border inclusive_border)) { | ||||
| 9934 | 98 | 204 | my $borders = $area->{$attr} or next; | ||||
| 9935 | 52 52 | 52 110 | @{$lookup}{@$borders} = @$borders; | ||||
| 9936 | 52 | 89 | next if $start; | ||||
| 9937 | |||||||
| 9938 | # identify start interface and direction for area traversal | ||||||
| 9939 | 49 | 52 | $start = $borders->[0]; | ||||
| 9940 | 49 | 98 | $obj1 = $attr eq 'border' | ||||
| 9941 | ? $start->{zone} # proceed with zone | ||||||
| 9942 | : $start->{router}; # proceed with router | ||||||
| 9943 | } | ||||||
| 9944 | |||||||
| 9945 | # Collect zones and routers of area and keep track of borders found. | ||||||
| 9946 | 49 | 80 | $lookup->{$start} = 'found'; | ||||
| 9947 | 49 | 76 | my $err = set_area($obj1, $area, $start); | ||||
| 9948 | 49 | 74 | next if $err; | ||||
| 9949 | |||||||
| 9950 | # Assert that all borders were found. | ||||||
| 9951 | 47 | 51 | for my $attr (qw(border inclusive_border)) { | ||||
| 9952 | 94 | 200 | my $borders = $area->{$attr} or next; | ||||
| 9953 | 49 59 | 65 206 | my @bad_intf = grep { $lookup->{$_} ne 'found' } @$borders | ||||
| 9954 | or next; | ||||||
| 9955 | 1 | 4 | err_msg("Invalid $attr of $area->{name}:\n - ", | ||||
| 9956 | 1 | 3 | join("\n - ", map { $_->{name} } @bad_intf)); | ||||
| 9957 | 2 | 6 | $area->{$attr} = | ||||
| 9958 | 1 | 2 | [ grep { $lookup->{$_} eq 'found' } @$borders ]; | ||||
| 9959 | } | ||||||
| 9960 | } | ||||||
| 9961 | |||||||
| 9962 | # Check whether area is empty (= consist of a single router) | ||||||
| 9963 | 64 64 | 55 162 | @{ $area->{zones} } or | ||||
| 9964 | warn_msg("$area->{name} is empty"); | ||||||
| 9965 | |||||||
| 9966 | # debug("$area->{name}:\n ", join "\n ", map $_->{name}, @{$area->{zones}}); | ||||||
| 9967 | } | ||||||
| 9968 | 337 | 286 | return; | ||||
| 9969 | } | ||||||
| 9970 | |||||||
| 9971 | ############################################################################### | ||||||
| 9972 | # Purpose : Find subset relation between areas, assure that no duplicate or | ||||||
| 9973 | # overlapping areas exist | ||||||
| 9974 | sub find_subset_relations { | ||||||
| 9975 | 337 | 0 | 264 | my %seen; # key:contained area, value: containing area | |||
| 9976 | |||||||
| 9977 | # Process all zones contained by one or more areas | ||||||
| 9978 | 337 | 383 | for my $zone (@zones) { | ||||
| 9979 | 882 | 1518 | $zone->{areas} or next; | ||||
| 9980 | |||||||
| 9981 | # Sort areas containing zone by ascending size | ||||||
| 9982 | 32 32 32 97 | 28 32 93 250 | my @areas = sort({ @{ $a->{zones} } <=> @{ $b->{zones} } || | ||||
| 9983 | $a->{name} cmp $b->{name} }#equal size? sort by name | ||||||
| 9984 | 97 | 85 | values %{ $zone->{areas} }) or next; # Skip empty hash. | ||||
| 9985 | |||||||
| 9986 | # Take the smallest area. | ||||||
| 9987 | 97 | 97 | my $next = shift @areas; | ||||
| 9988 | |||||||
| 9989 | 97 | 195 | while(@areas) { | ||||
| 9990 | 28 | 24 | my $small = $next; | ||||
| 9991 | 28 | 23 | $next = shift @areas; | ||||
| 9992 | 28 | 84 | next if $seen{$small}->{$next};# Already identified in other zone. | ||||
| 9993 | |||||||
| 9994 | # Check that each zone of $small is part of $next. | ||||||
| 9995 | 18 | 18 | my $ok = 1; | ||||
| 9996 | 18 18 | 17 24 | for my $zone (@{ $small->{zones} }) { | ||||
| 9997 | 28 | 70 | if(!$zone->{areas}->{$next}) { | ||||
| 9998 | 1 | 1 | $ok = 0; | ||||
| 9999 | 1 | 5 | err_msg("Overlapping $small->{name} and $next->{name}"); | ||||
| 10000 | 1 | 1 | last; | ||||
| 10001 | } | ||||||
| 10002 | } | ||||||
| 10003 | |||||||
| 10004 | # check for duplicates | ||||||
| 10005 | 18 | 30 | if ($ok) { | ||||
| 10006 | 17 17 17 | 13 21 28 | if (@{ $small->{zones} } == @{ $next->{zones} }) { | ||||
| 10007 | 1 | 60 | err_msg("Duplicate $small->{name} and $next->{name}"); | ||||
| 10008 | } | ||||||
| 10009 | |||||||
| 10010 | # reference containing area | ||||||
| 10011 | else { | ||||||
| 10012 | 16 | 23 | $small->{subset_of} = $next; | ||||
| 10013 | # debug "$small->{name} < $next->{name}"; | ||||||
| 10014 | } | ||||||
| 10015 | } | ||||||
| 10016 | |||||||
| 10017 | #keep track of processed areas | ||||||
| 10018 | 18 | 61 | $seen{$small}->{$next} = 1; | ||||
| 10019 | } | ||||||
| 10020 | } | ||||||
| 10021 | 337 | 423 | return; | ||||
| 10022 | } | ||||||
| 10023 | |||||||
| 10024 | ############################################################################# | ||||||
| 10025 | # Purpose : Check, that area subset relations hold for routers: | ||||||
| 10026 | # : Case 1: If a router R is located inside areas A1 and A2 via | ||||||
| 10027 | # 'inclusive_border', then A1 and A2 must be in subset relation. | ||||||
| 10028 | # : Case 2: If area A1 and A2 are in subset relation and A1 includes R, | ||||||
| 10029 | # then A2 also needs to include R either from 'inclusive_border' or | ||||||
| 10030 | # R is surrounded by zones located inside A2. | ||||||
| 10031 | # Comments : This is needed to get consistent inheritance with | ||||||
| 10032 | # 'router_attributes'. | ||||||
| 10033 | sub check_routers_in_nested_areas { | ||||||
| 10034 | |||||||
| 10035 | 337 | 0 | 325 | my ($has_inclusive_borders) = @_; | |||
| 10036 | # Case 1: Identify routers contained by areas via 'inclusive_border' | ||||||
| 10037 | 337 | 876 | for my $router (sort by_name values %$has_inclusive_borders) { | ||||
| 10038 | |||||||
| 10039 | # Sort all areas having this router as inclusive_border by size. | ||||||
| 10040 | 3 | 4 | my @areas = | ||||
| 10041 | 3 3 12 | 2 12 26 | sort({ @{ $a->{zones} } <=> @{ $b->{zones} } || # ascending order | ||||
| 10042 | $a->{name} cmp $b->{name} } # equal size? sort by name | ||||||
| 10043 | 12 | 14 | values %{ $router->{areas} }); | ||||
| 10044 | |||||||
| 10045 | # Take the smallest area. | ||||||
| 10046 | 12 | 12 | my $next = shift @areas; | ||||
| 10047 | |||||||
| 10048 | # Pairwisely check containing areas for subset relation. | ||||||
| 10049 | 12 | 30 | while(@areas) { | ||||
| 10050 | 3 | 7 | my $small = $next; | ||||
| 10051 | 3 | 3 | $next = shift @areas; | ||||
| 10052 | 3 | 9 | my $big = $small->{subset_of} || ''; # extract containing area | ||||
| 10053 | 3 | 13 | next if $next eq $big; | ||||
| 10054 | 1 | 7 | err_msg("$small->{name} and $next->{name} must be", | ||||
| 10055 | " in subset relation,\n because both have", | ||||||
| 10056 | " $router->{name} as 'inclusive_border'"); | ||||||
| 10057 | } | ||||||
| 10058 | } | ||||||
| 10059 | |||||||
| 10060 | # Case 2: Identify areas in subset relation | ||||||
| 10061 | 337 | 426 | for my $area (@areas) { | ||||
| 10062 | 66 | 161 | my $big = $area->{subset_of} or next; | ||||
| 10063 | |||||||
| 10064 | # Assure routers of the subset area to be located in containing area too | ||||||
| 10065 | 16 16 | 16 35 | for my $router (@{ $area->{managed_routers} }) { | ||||
| 10066 | 8 | 26 | next if $router->{areas}->{$big}; | ||||
| 10067 | 1 | 6 | err_msg("$router->{name} must be located in $big->{name},\n", | ||||
| 10068 | " because it is located in $area->{name}\n", | ||||||
| 10069 | " and both areas are in subset relation\n", | ||||||
| 10070 | " (use attribute 'inclusive_border')"); | ||||||
| 10071 | } | ||||||
| 10072 | } | ||||||
| 10073 | 337 | 309 | return; | ||||
| 10074 | } | ||||||
| 10075 | |||||||
| 10076 | ############################################################################## | ||||||
| 10077 | # Purpose : Delete unused attributes in area objects. | ||||||
| 10078 | sub clean_areas { | ||||||
| 10079 | 337 | 0 | 387 | for my $area (@areas) { | |||
| 10080 | 66 | 98 | delete $area->{intf_lookup}; | ||||
| 10081 | 66 66 | 57 117 | for my $interface (@{ $area->{border} }) { | ||||
| 10082 | 44 | 42 | delete $interface->{is_border}; | ||||
| 10083 | 44 | 83 | delete $interface->{is_inclusive}; | ||||
| 10084 | } | ||||||
| 10085 | } | ||||||
| 10086 | 337 | 281 | return; | ||||
| 10087 | } | ||||||
| 10088 | |||||||
| 10089 | ############################################################################### | ||||||
| 10090 | # Purpose : Create zones and areas. | ||||||
| 10091 | sub set_zone { | ||||||
| 10092 | 337 | 0 | 456 | progress('Preparing security zones and areas'); | |||
| 10093 | 337 | 474 | set_zones(); | ||||
| 10094 | 337 | 492 | cluster_zones(); | ||||
| 10095 | 337 | 489 | check_no_in_acl(); #TODO: place somewhere else? | ||||
| 10096 | 337 | 472 | my $crosslink_routers = check_crosslink(); #TODO: place somewhere else? | ||||
| 10097 | 337 | 494 | cluster_crosslink_routers($crosslink_routers); #TODO: place somewhere else? | ||||
| 10098 | 337 | 443 | my $has_inclusive_borders = prepare_area_borders(); | ||||
| 10099 | 337 | 481 | set_areas(); | ||||
| 10100 | 337 | 448 | find_subset_relations(); | ||||
| 10101 | 337 | 466 | check_routers_in_nested_areas($has_inclusive_borders); | ||||
| 10102 | 337 | 427 | clean_areas(); # delete unused attributes | ||||
| 10103 | 337 | 464 | link_aggregates(); | ||||
| 10104 | 337 | 432 | inherit_attributes(); | ||||
| 10105 | 337 | 513 | return; | ||||
| 10106 | } | ||||||
| 10107 | |||||||
| 10108 | #################################################################### | ||||||
| 10109 | # Virtual interfaces | ||||||
| 10110 | #################################################################### | ||||||
| 10111 | |||||||
| 10112 | # Interfaces with identical virtual IP must be located inside the same loop. | ||||||
| 10113 | sub check_virtual_interfaces { | ||||||
| 10114 | 332 | 0 | 289 | my %seen; | |||
| 10115 | 332 | 382 | for my $interface (@virtual_interfaces) { | ||||
| 10116 | 72 | 115 | my $related = $interface->{redundancy_interfaces} or next; | ||||
| 10117 | |||||||
| 10118 | # Loops inside a security zone are not known | ||||||
| 10119 | # and therefore can't be checked. | ||||||
| 10120 | 72 | 64 | my $router = $interface->{router}; | ||||
| 10121 | 72 | 164 | next if not($router->{managed} or $router->{semi_managed}); | ||||
| 10122 | |||||||
| 10123 | 59 | 114 | $seen{$related} and next; | ||||
| 10124 | 28 | 42 | $seen{$related} = 1; | ||||
| 10125 | |||||||
| 10126 | 28 | 20 | my $err; | ||||
| 10127 | 28 | 33 | for my $v (@$related) { | ||||
| 10128 | 59 | 117 | if (not $v->{router}->{loop}) { | ||||
| 10129 | 0 | 0 | err_msg("Virtual IP of $v->{name}\n", | ||||
| 10130 | " must be located inside cyclic sub-graph"); | ||||||
| 10131 | 0 | 0 | $err = 1; | ||||
| 10132 | } | ||||||
| 10133 | } | ||||||
| 10134 | 28 | 50 | next if $err; | ||||
| 10135 | 4 59 | 7 91 | equal(map { $_->{loop} } @$related) | ||||
| 10136 | or err_msg("Virtual interfaces\n ", | ||||||
| 10137 | 28 | 33 | join(', ', map({ $_->{name} } @$related)), | ||||
| 10138 | "\n must all be part of the same cyclic sub-graph"); | ||||||
| 10139 | } | ||||||
| 10140 | 332 | 376 | return; | ||||
| 10141 | } | ||||||
| 10142 | |||||||
| 10143 | #################################################################### | ||||||
| 10144 | # Check pathrestrictions | ||||||
| 10145 | #################################################################### | ||||||
| 10146 | |||||||
| 10147 | sub check_pathrestrictions { | ||||||
| 10148 | RESTRICT: | ||||||
| 10149 | 332 | 0 | 576 | for my $restrict (values %pathrestrictions) { | |||
| 10150 | 29 | 34 | my $elements = $restrict->{elements}; | ||||
| 10151 | 29 | 47 | next if !@$elements; | ||||
| 10152 | 29 | 22 | my $deleted; | ||||
| 10153 | 29 | 37 | for my $obj (@$elements) { | ||||
| 10154 | |||||||
| 10155 | # Interfaces with pathrestriction need to be located | ||||||
| 10156 | # inside or at the border of cyclic graphs. | ||||||
| 10157 | 60 | 155 | if ( | ||||
| 10158 | not( $obj->{loop} | ||||||
| 10159 | || $obj->{router}->{loop} | ||||||
| 10160 | || $obj->{zone}->{loop} | ||||||
| 10161 | || $obj->{disabled}) | ||||||
| 10162 | ) | ||||||
| 10163 | { | ||||||
| 10164 | 0 | 0 | delete $obj->{path_restrict}; | ||||
| 10165 | 0 | 0 | warn_msg("Ignoring $restrict->{name} at $obj->{name}\n", | ||||
| 10166 | " because it isn't located inside cyclic graph"); | ||||||
| 10167 | 0 | 0 | $obj = undef; | ||||
| 10168 | 0 | 0 | $deleted = 1; | ||||
| 10169 | } | ||||||
| 10170 | } | ||||||
| 10171 | 29 | 46 | if ($deleted) { | ||||
| 10172 | 0 0 | 0 0 | $elements = $restrict->{elements} = [ grep { $_ } @$elements ]; | ||||
| 10173 | 0 | 0 | if (1 == @$elements) { | ||||
| 10174 | 0 | 0 | $elements = $restrict->{elements} = []; | ||||
| 10175 | } | ||||||
| 10176 | } | ||||||
| 10177 | 29 | 44 | next if !@$elements; | ||||
| 10178 | |||||||
| 10179 | # Check for useless pathrestriction where all interfaces | ||||||
| 10180 | # are located inside a loop with all routers unmanaged. | ||||||
| 10181 | # | ||||||
| 10182 | # Some router is managed. | ||||||
| 10183 | 29 60 | 32 179 | grep({ $_->{router}->{managed} || $_->{router}->{routing_only} } | ||||
| 10184 | @$elements) and next; | ||||||
| 10185 | |||||||
| 10186 | # Different zones or zone_clusters, hence some router is managed. | ||||||
| 10187 | 6 13 13 | 8 32 18 | equal(map { $_->{zone_cluster} || $_ } map { $_->{zone} } @$elements) | ||||
| 10188 | or next; | ||||||
| 10189 | |||||||
| 10190 | # If there exists some neighbour zone or zone_cluster, located | ||||||
| 10191 | # inside the same loop, then some router is managed. | ||||||
| 10192 | # Interface is known to have attribute {loop}, | ||||||
| 10193 | # because it is unmanaged and has pathrestriction. | ||||||
| 10194 | 6 | 8 | my $element = $elements->[0]; | ||||
| 10195 | 6 | 7 | my $loop = $element->{loop}; | ||||
| 10196 | 6 | 5 | my $zone = $element->{zone}; | ||||
| 10197 | 6 | 11 | my $zone_cluster = $zone->{zone_cluster} || [ $zone ]; | ||||
| 10198 | 6 | 11 | for my $zone1 (@$zone_cluster) { | ||||
| 10199 | 7 7 | 4 12 | for my $interface (@{ $zone->{interfaces} }) { | ||||
| 10200 | 12 | 7 | my $router = $interface->{router}; | ||||
| 10201 | 12 12 | 12 14 | for my $interface2 (@{ $router->{interfaces} }) { | ||||
| 10202 | 22 | 21 | my $zone2 = $interface2->{zone}; | ||||
| 10203 | 22 | 40 | next if $zone2 eq $zone; | ||||
| 10204 | 14 | 25 | if (my $cluster2 = $zone2->{zone_cluster}) { | ||||
| 10205 | 9 | 26 | next if $cluster2 eq $zone_cluster; | ||||
| 10206 | } | ||||||
| 10207 | 7 | 12 | if (my $loop2 = $zone2->{loop}) { | ||||
| 10208 | 5 | 16 | if ($loop eq $loop2) { | ||||
| 10209 | |||||||
| 10210 | # Found other zone in same loop. | ||||||
| 10211 | 5 | 15 | next RESTRICT; | ||||
| 10212 | } | ||||||
| 10213 | } | ||||||
| 10214 | } | ||||||
| 10215 | } | ||||||
| 10216 | } | ||||||
| 10217 | |||||||
| 10218 | 1 | 4 | warn_msg("Useless $restrict->{name}.\n", | ||||
| 10219 | " All interfaces are unmanaged and", | ||||||
| 10220 | " located inside the same security zone" | ||||||
| 10221 | ); | ||||||
| 10222 | 1 | 4 | $restrict->{elements} = []; | ||||
| 10223 | } | ||||||
| 10224 | 332 29 29 | 408 20 48 | push @pathrestrictions, grep({ @{ $_->{elements} } } | ||||
| 10225 | values %pathrestrictions); | ||||||
| 10226 | 332 | 295 | return; | ||||
| 10227 | } | ||||||
| 10228 | |||||||
| 10229 | #################################################################### | ||||||
| 10230 | # Optimize a class of pathrestrictions. | ||||||
| 10231 | # Find partitions of cyclic graphs that are separated | ||||||
| 10232 | # by pathrestrictions. | ||||||
| 10233 | # This allows faster graph traversal. | ||||||
| 10234 | # When entering a partition, we can already decide, | ||||||
| 10235 | # if end of path is reachable or not. | ||||||
| 10236 | #################################################################### | ||||||
| 10237 | |||||||
| 10238 | sub traverse_loop_part { | ||||||
| 10239 | 332 | 0 | 346 | my ($obj, $in_interface, $mark, $seen) = @_; | |||
| 10240 | 332 | 587 | return if $obj->{reachable_part}->{$mark}; | ||||
| 10241 | 282 | 375 | return if $obj->{active_path}; | ||||
| 10242 | 282 | 343 | local $obj->{active_path} = 1; | ||||
| 10243 | |||||||
| 10244 | # Mark $obj as member of partition. | ||||||
| 10245 | 282 | 309 | $obj->{reachable_part}->{$mark} = 1; | ||||
| 10246 | # debug "$obj->{name} in loop part $mark"; | ||||||
| 10247 | 282 | 308 | my $is_zone = is_zone($obj); | ||||
| 10248 | 282 282 | 231 333 | for my $interface (@{ $obj->{interfaces} }) { | ||||
| 10249 | 936 | 1665 | next if $interface eq $in_interface; | ||||
| 10250 | 654 | 967 | next if $interface->{main_interface}; | ||||
| 10251 | 402 | 611 | if (my $hash = $seen->{$interface}) { | ||||
| 10252 | 119 | 150 | my $current = $is_zone ? 'zone' : 'router'; | ||||
| 10253 | 119 | 214 | $hash->{$current} = $mark; | ||||
| 10254 | } | ||||||
| 10255 | else { | ||||||
| 10256 | 283 | 432 | next if !$interface->{loop}; | ||||
| 10257 | 227 | 292 | my $next = $interface->{$is_zone ? 'router' : 'zone'}; | ||||
| 10258 | 227 | 297 | traverse_loop_part($next, $interface, $mark, $seen); | ||||
| 10259 | } | ||||||
| 10260 | } | ||||||
| 10261 | 282 | 452 | return; | ||||
| 10262 | } | ||||||
| 10263 | |||||||
| 10264 | # Find partitions of a cyclic graph that are separated by pathrestrictions. | ||||||
| 10265 | # Mark each found partition with a distinct number. | ||||||
| 10266 | sub optimize_pathrestrictions { | ||||||
| 10267 | 332 | 0 | 291 | my $mark = 1; | |||
| 10268 | 332 | 355 | for my $restrict (@pathrestrictions) { | ||||
| 10269 | 56 | 59 | my $elements = $restrict->{elements}; | ||||
| 10270 | |||||||
| 10271 | # Create a hash with all elements as key. | ||||||
| 10272 | # Used for efficient lookup, if some interface | ||||||
| 10273 | # is part of current pathrestriction. | ||||||
| 10274 | # Value is an initially empty hash. | ||||||
| 10275 | # Keys 'router' and 'zone' are added during traversal. | ||||||
| 10276 | # Key indicates if element was reached from router or network. | ||||||
| 10277 | # Value is $mark of the adjacent partition. | ||||||
| 10278 | 56 | 61 | my $seen = {}; | ||||
| 10279 | 56 | 62 | for my $interface (@$elements) { | ||||
| 10280 | 117 | 238 | $seen->{$interface} = {}; | ||||
| 10281 | } | ||||||
| 10282 | |||||||
| 10283 | # Traverse loop starting from each element of pathrestriction | ||||||
| 10284 | # in both directions. | ||||||
| 10285 | 56 | 52 | my $start_mark = $mark; | ||||
| 10286 | 56 | 58 | for my $interface (@$elements) { | ||||
| 10287 | 117 | 142 | my $reached = $seen->{$interface}; | ||||
| 10288 | 117 | 117 | for my $direction (qw(zone router)) { | ||||
| 10289 | |||||||
| 10290 | # This side of the interface has already been entered | ||||||
| 10291 | # from some previously found partition. | ||||||
| 10292 | 234 | 423 | next if $reached->{$direction}; | ||||
| 10293 | 115 | 112 | my $obj = $interface->{$direction}; | ||||
| 10294 | |||||||
| 10295 | # Ignore interface at border of loop in direction | ||||||
| 10296 | # leaving the loop. | ||||||
| 10297 | 115 | 187 | if (!$obj->{loop}) { | ||||
| 10298 | 10 | 13 | $reached->{$direction} = 'none'; | ||||
| 10299 | 10 | 13 | next; | ||||
| 10300 | } | ||||||
| 10301 | 105 | 113 | $reached->{$direction} = $mark; | ||||
| 10302 | 105 | 126 | traverse_loop_part($obj, $interface, $mark, $seen); | ||||
| 10303 | 105 | 137 | $mark++; | ||||
| 10304 | } | ||||||
| 10305 | } | ||||||
| 10306 | |||||||
| 10307 | # Analyze found partitions. | ||||||
| 10308 | |||||||
| 10309 | # If only a single partition was found, nothing can be optimized. | ||||||
| 10310 | 56 | 114 | next if $mark <= $start_mark + 1; | ||||
| 10311 | |||||||
| 10312 | # No outgoing restriction needed for a pathrestriction surrounding a | ||||||
| 10313 | # single zone. A rule from zone to zone would be unenforceable anyway. | ||||||
| 10314 | # | ||||||
| 10315 | # But this restriction is needed for one special case: | ||||||
| 10316 | # src=zone, dst=interface:r.zone | ||||||
| 10317 | # We must not enter router:r from outside the zone. | ||||||
| 10318 | # if (equal(map { $_->{zone} } @$elements)) { | ||||||
| 10319 | # $seen->{$_}->{router} = 'none' for @$elements; | ||||||
| 10320 | # } | ||||||
| 10321 | |||||||
| 10322 | # Collect interfaces at border of newly found partitions. | ||||||
| 10323 | 47 | 45 | my $has_interior; | ||||
| 10324 | 47 | 48 | for my $interface (@$elements) { | ||||
| 10325 | 98 | 121 | my $reached = $seen->{$interface}; | ||||
| 10326 | |||||||
| 10327 | # Check for pathrestriction inside a partition. | ||||||
| 10328 | 98 | 239 | if ($reached->{zone} eq $reached->{router} && | ||||
| 10329 | $reached->{zone} ne 'none') | ||||||
| 10330 | { | ||||||
| 10331 | 0 | 0 | $has_interior++; | ||||
| 10332 | } | ||||||
| 10333 | else { | ||||||
| 10334 | 98 | 97 | for my $direction (qw(zone router)) { | ||||
| 10335 | 196 | 194 | my $mark = $reached->{$direction}; | ||||
| 10336 | 196 | 263 | next if $mark eq 'none'; | ||||
| 10337 | 196 | 169 | my $obj = $interface->{$direction}; | ||||
| 10338 | 196 196 | 155 604 | push @{ $interface->{reachable_at}->{$obj} }, $mark; | ||||
| 10339 | # debug "$interface->{name}: $direction $mark"; | ||||||
| 10340 | } | ||||||
| 10341 | } | ||||||
| 10342 | } | ||||||
| 10343 | |||||||
| 10344 | # Original pathrestriction is needless, if all interfaces are | ||||||
| 10345 | # border of some partition. The restriction is implemented by | ||||||
| 10346 | # the new attribute {reachable_at}. | ||||||
| 10347 | 47 | 78 | if (!$has_interior) { | ||||
| 10348 | 47 | 54 | for my $interface (@$elements) { | ||||
| 10349 | # debug "remove $restrict->{name} from $interface->{name}"; | ||||||
| 10350 | 98 | 139 | aref_delete($interface->{path_restrict}, $restrict) or | ||||
| 10351 | internal_err("Can't remove $restrict->{name}", | ||||||
| 10352 | " from $interface->{name}"); | ||||||
| 10353 | |||||||
| 10354 | # Delete empty array to speed up checks in cluster_path_mark. | ||||||
| 10355 | 98 98 | 77 161 | if (!@{ $interface->{path_restrict} }) { | ||||
| 10356 | 95 | 242 | delete $interface->{path_restrict}; | ||||
| 10357 | } | ||||||
| 10358 | } | ||||||
| 10359 | } | ||||||
| 10360 | else { | ||||||
| 10361 | # debug "Can't opt. $restrict->{name}, has $has_interior interior"; | ||||||
| 10362 | } | ||||||
| 10363 | } | ||||||
| 10364 | 332 | 300 | return; | ||||
| 10365 | } | ||||||
| 10366 | |||||||
| 10367 | #################################################################### | ||||||
| 10368 | # Set paths for efficient topology traversal | ||||||
| 10369 | #################################################################### | ||||||
| 10370 | |||||||
| 10371 | # Parameters: | ||||||
| 10372 | # $obj: a managed or semi-managed router or a zone | ||||||
| 10373 | # $to_zone1: interface of $obj; go this direction to reach zone1 | ||||||
| 10374 | # $distance: distance to zone1 | ||||||
| 10375 | # Return values: | ||||||
| 10376 | # 1. maximal value of $distance used in current subtree. | ||||||
| 10377 | # 2. | ||||||
| 10378 | # - undef: found path is not part of a loop | ||||||
| 10379 | # - loop-marker: | ||||||
| 10380 | # - found path is part of a loop | ||||||
| 10381 | # - a hash, which is referenced by all members of the loop | ||||||
| 10382 | # with this attributes: | ||||||
| 10383 | # - exit: that node of the loop where zone1 is reached | ||||||
| 10384 | # - distance: distance of the exit node + 1. | ||||||
| 10385 | sub setpath_obj; | ||||||
| 10386 | |||||||
| 10387 | sub setpath_obj { | ||||||
| 10388 | 1505 | 0 | 1427 | my ($obj, $to_zone1, $distance) = @_; | |||
| 10389 | |||||||
| 10390 | # debug("--$distance: $obj->{name} --> ". ($to_zone1 && $to_zone1->{name})); | ||||||
| 10391 | 1505 | 2123 | if ($obj->{active_path}) { | ||||
| 10392 | |||||||
| 10393 | # Found a loop; this is possibly exit of the loop to zone1. | ||||||
| 10394 | # Generate unique loop marker which references this object. | ||||||
| 10395 | # Distance is needed for cluster navigation. | ||||||
| 10396 | # We need a copy of the distance value inside the loop marker | ||||||
| 10397 | # because distance at object is reset later to the value of the | ||||||
| 10398 | # cluster exit object. | ||||||
| 10399 | # We must use an intermediate distance value for cluster_navigation | ||||||
| 10400 | # to work. | ||||||
| 10401 | 119 | 123 | my $new_distance = $obj->{distance} + 1; | ||||
| 10402 | 119 | 278 | my $loop = $to_zone1->{loop} = { | ||||
| 10403 | exit => $obj, | ||||||
| 10404 | distance => $new_distance, | ||||||
| 10405 | }; | ||||||
| 10406 | 119 | 187 | return ($new_distance, $loop); | ||||
| 10407 | } | ||||||
| 10408 | |||||||
| 10409 | # Mark current path for loop detection. | ||||||
| 10410 | 1386 | 1690 | local $obj->{active_path} = 1; | ||||
| 10411 | 1386 | 1332 | $obj->{distance} = $distance; | ||||
| 10412 | 1386 | 1045 | my $max_distance = $distance; | ||||
| 10413 | |||||||
| 10414 | 1386 | 1527 | my $get_next = is_router($obj) ? 'zone' : 'router'; | ||||
| 10415 | 1386 1386 | 1204 1718 | for my $interface (@{ $obj->{interfaces} }) { | ||||
| 10416 | |||||||
| 10417 | # Ignore interface where we reached this obj. | ||||||
| 10418 | 2316 | 4599 | next if $interface eq $to_zone1; | ||||
| 10419 | |||||||
| 10420 | # Ignore interface which is the other entry of a loop which is | ||||||
| 10421 | # already marked. | ||||||
| 10422 | 1277 | 1859 | next if $interface->{loop}; | ||||
| 10423 | 1158 | 1126 | my $next = $interface->{$get_next}; | ||||
| 10424 | |||||||
| 10425 | # Increment by 2 because we need an intermediate value above. | ||||||
| 10426 | 1158 | 1981 | (my $max, my $loop) = setpath_obj($next, $interface, $distance + 2); | ||||
| 10427 | 1158 | 1726 | $max_distance = $max if $max > $max_distance; | ||||
| 10428 | 1158 | 1270 | if ($loop) { | ||||
| 10429 | 316 | 279 | my $loop_obj = $loop->{exit}; | ||||
| 10430 | |||||||
| 10431 | # Found exit of loop in direction to zone1. | ||||||
| 10432 | 316 | 636 | if ($obj eq $loop_obj) { | ||||
| 10433 | |||||||
| 10434 | # Mark with a different marker linking to itself. | ||||||
| 10435 | # If current loop is part of a cluster, | ||||||
| 10436 | # this marker will be overwritten later. | ||||||
| 10437 | # Otherwise this is the exit of a cluster of loops. | ||||||
| 10438 | 61 | 237 | $obj->{loop} ||= { exit => $obj, distance => $distance, }; | ||||
| 10439 | } | ||||||
| 10440 | |||||||
| 10441 | # Found intermediate loop node which was marked before. | ||||||
| 10442 | elsif (my $loop2 = $obj->{loop}) { | ||||||
| 10443 | 58 | 103 | if ($loop ne $loop2) { | ||||
| 10444 | 58 | 83 | if ($loop->{distance} < $loop2->{distance}) { | ||||
| 10445 | 10 | 9 | $loop2->{redirect} = $loop; | ||||
| 10446 | 10 | 13 | $obj->{loop} = $loop; | ||||
| 10447 | } | ||||||
| 10448 | else { | ||||||
| 10449 | 48 | 60 | $loop->{redirect} = $loop2; | ||||
| 10450 | } | ||||||
| 10451 | } | ||||||
| 10452 | } | ||||||
| 10453 | |||||||
| 10454 | # Found intermediate loop node. | ||||||
| 10455 | else { | ||||||
| 10456 | 197 | 222 | $obj->{loop} = $loop; | ||||
| 10457 | } | ||||||
| 10458 | 316 | 561 | $interface->{loop} = $loop; | ||||
| 10459 | } | ||||||
| 10460 | else { | ||||||
| 10461 | |||||||
| 10462 | # Continue marking loop-less path. | ||||||
| 10463 | 842 | 1483 | $interface->{main} = $obj; | ||||
| 10464 | } | ||||||
| 10465 | } | ||||||
| 10466 | 1386 | 3117 | if ($obj->{loop} and $obj->{loop}->{exit} ne $obj) { | ||||
| 10467 | 197 | 372 | return ($max_distance, $obj->{loop}); | ||||
| 10468 | |||||||
| 10469 | } | ||||||
| 10470 | else { | ||||||
| 10471 | 1189 | 1288 | $obj->{main} = $to_zone1; | ||||
| 10472 | 1189 | 1923 | return $max_distance; | ||||
| 10473 | } | ||||||
| 10474 | } | ||||||
| 10475 | |||||||
| 10476 | # Find cluster of directly connected loops. | ||||||
| 10477 | # Find exit node of the cluster in direction to zone1; | ||||||
| 10478 | # Its loop attribute has a reference to the node itself. | ||||||
| 10479 | # Add this exit node as marker to all loops belonging to the cluster. | ||||||
| 10480 | sub set_loop_cluster { | ||||||
| 10481 | 316 | 0 | 232 | my ($loop) = @_; | |||
| 10482 | 316 | 409 | if (my $marker = $loop->{cluster_exit}) { | ||||
| 10483 | 197 | 190 | return $marker; | ||||
| 10484 | } | ||||||
| 10485 | else { | ||||||
| 10486 | 119 | 104 | my $exit = $loop->{exit}; | ||||
| 10487 | |||||||
| 10488 | # Exit node has loop marker which references the node itself. | ||||||
| 10489 | 119 | 252 | if ($exit->{loop} eq $loop) { | ||||
| 10490 | |||||||
| 10491 | # debug("Loop $exit->{name},$loop->{distance} is in cluster $exit->{name}"); | ||||||
| 10492 | 58 | 96 | return $loop->{cluster_exit} = $exit; | ||||
| 10493 | } | ||||||
| 10494 | else { | ||||||
| 10495 | 61 | 120 | my $cluster = set_loop_cluster($exit->{loop}); | ||||
| 10496 | |||||||
| 10497 | # debug("Loop $exit->{name},$loop->{distance} is in cluster $cluster->{name}"); | ||||||
| 10498 | 61 | 98 | return $loop->{cluster_exit} = $cluster; | ||||
| 10499 | } | ||||||
| 10500 | } | ||||||
| 10501 | } | ||||||
| 10502 | |||||||
| 10503 | sub setpath { | ||||||
| 10504 | 337 | 0 | 481 | progress('Preparing fast path traversal'); | |||
| 10505 | |||||||
| 10506 | 337 | 554 | @zones or fatal_err("Topology seems to be empty"); | ||||
| 10507 | 332 690 | 372 1711 | my @path_routers = grep { $_->{managed} || $_->{semi_managed} } @routers; | ||||
| 10508 | 332 | 314 | my $start_distance = 0; | ||||
| 10509 | |||||||
| 10510 | # Find one or more connected partitions in whole topology. | ||||||
| 10511 | 332 | 398 | for my $obj (@zones, @path_routers) { | ||||
| 10512 | 1366 | 3365 | next if $obj->{main} or $obj->{loop}; | ||||
| 10513 | |||||||
| 10514 | # Take an arbitrary obj from @zones, name it "zone1". | ||||||
| 10515 | 347 | 306 | my $zone1 = $obj; | ||||
| 10516 | |||||||
| 10517 | # Starting with zone1, do a traversal of all connected nodes, | ||||||
| 10518 | # to find a path from every zone and router to zone1. | ||||||
| 10519 | # Second parameter is used as placeholder for a not existing | ||||||
| 10520 | # starting interface. | ||||||
| 10521 | # Value must be "false" and unequal to any interface. | ||||||
| 10522 | # Third parameter is distance from $zone1 to $zone1. | ||||||
| 10523 | 347 | 506 | my $max = setpath_obj($zone1, '', $start_distance); | ||||
| 10524 | 347 | 456 | $start_distance = $max + 1; | ||||
| 10525 | } | ||||||
| 10526 | |||||||
| 10527 | 332 | 430 | for my $obj (@zones, @path_routers) { | ||||
| 10528 | 1366 | 2236 | my $loop = $obj->{loop} or next; | ||||
| 10529 | |||||||
| 10530 | # Check all zones and routers located inside a cyclic | ||||||
| 10531 | # graph. Propagate loop exit into sub-loops. | ||||||
| 10532 | 255 | 404 | while (my $next = $loop->{redirect}) { | ||||
| 10533 | |||||||
| 10534 | # debug("Redirect: $loop->{exit}->{name} -> $next->{exit}->{name}"); | ||||||
| 10535 | 44 | 76 | $loop = $next; | ||||
| 10536 | } | ||||||
| 10537 | 255 | 224 | $obj->{loop} = $loop; | ||||
| 10538 | |||||||
| 10539 | # Mark connected loops with cluster exit. | ||||||
| 10540 | 255 | 283 | set_loop_cluster($loop); | ||||
| 10541 | |||||||
| 10542 | # Set distance of loop objects to value of cluster exit. | ||||||
| 10543 | 255 | 336 | $obj->{distance} = $loop->{cluster_exit}->{distance}; | ||||
| 10544 | } | ||||||
| 10545 | 332 | 387 | for my $router (@path_routers) { | ||||
| 10546 | 484 484 | 384 601 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 10547 | 1138 | 2070 | if (my $loop = $interface->{loop}) { | ||||
| 10548 | 316 | 464 | while (my $next = $loop->{redirect}) { | ||||
| 10549 | 152 | 213 | $loop = $next; | ||||
| 10550 | } | ||||||
| 10551 | 316 | 447 | $interface->{loop} = $loop; | ||||
| 10552 | } | ||||||
| 10553 | } | ||||||
| 10554 | } | ||||||
| 10555 | |||||||
| 10556 | # This is called here and not at link_topology because it needs | ||||||
| 10557 | # attribute {loop}. | ||||||
| 10558 | 332 | 533 | check_pathrestrictions(); | ||||
| 10559 | 332 | 419 | check_virtual_interfaces(); | ||||
| 10560 | 332 | 418 | optimize_pathrestrictions(); | ||||
| 10561 | 332 | 361 | return; | ||||
| 10562 | } | ||||||
| 10563 | |||||||
| 10564 | #################################################################### | ||||||
| 10565 | # Efficient path traversal. | ||||||
| 10566 | #################################################################### | ||||||
| 10567 | |||||||
| 10568 | my %obj2path; | ||||||
| 10569 | |||||||
| 10570 | sub get_path { | ||||||
| 10571 | 1147 | 0 | 929 | my ($obj) = @_; | |||
| 10572 | 1147 | 1051 | my $type = ref $obj; | ||||
| 10573 | 1147 | 789 | my $result; | ||||
| 10574 | 1147 | 2338 | if ($type eq 'Network') { | ||||
| 10575 | 435 | 441 | $result = $obj->{zone}; | ||||
| 10576 | } | ||||||
| 10577 | elsif ($type eq 'Subnet') { | ||||||
| 10578 | 71 | 87 | $result = $obj->{network}->{zone}; | ||||
| 10579 | } | ||||||
| 10580 | elsif ($type eq 'Interface') { | ||||||
| 10581 | 192 | 180 | my $router = $obj->{router}; | ||||
| 10582 | 192 | 440 | if ($router->{managed} || $router->{semi_managed}) { | ||||
| 10583 | |||||||
| 10584 | # If this is a secondary interface, we can't use it to enter | ||||||
| 10585 | # the router, because it has an active pathrestriction attached. | ||||||
| 10586 | # But it doesn't matter if we use the main interface instead. | ||||||
| 10587 | 131 | 278 | $obj = $obj->{main_interface} || $obj; | ||||
| 10588 | |||||||
| 10589 | # Special handling needed if $src or $dst is interface | ||||||
| 10590 | # which has pathrestriction attached. | ||||||
| 10591 | 131 | 378 | if ($obj->{path_restrict} || $obj->{reachable_at}) { | ||||
| 10592 | 40 | 41 | $result = $obj; | ||||
| 10593 | } | ||||||
| 10594 | else { | ||||||
| 10595 | 91 | 106 | $result = $obj->{router}; | ||||
| 10596 | } | ||||||
| 10597 | } | ||||||
| 10598 | else { | ||||||
| 10599 | 61 | 80 | $result = $obj->{network}->{zone}; | ||||
| 10600 | } | ||||||
| 10601 | } | ||||||
| 10602 | |||||||
| 10603 | # This is used, if called from path_auto_interfaces. | ||||||
| 10604 | elsif ($type eq 'Router') { | ||||||
| 10605 | 18 | 53 | if ($obj->{managed} || $obj->{semi_managed}) { | ||||
| 10606 | 9 | 11 | $result = $obj; | ||||
| 10607 | } | ||||||
| 10608 | else { | ||||||
| 10609 | 9 | 13 | $result = $obj->{interfaces}->[0]->{network}->{zone}; | ||||
| 10610 | } | ||||||
| 10611 | } | ||||||
| 10612 | |||||||
| 10613 | # This is used, if path_walk is called from find_active_routes. | ||||||
| 10614 | elsif ($type eq 'Zone') { | ||||||
| 10615 | 426 | 367 | $result = $obj; | ||||
| 10616 | } | ||||||
| 10617 | |||||||
| 10618 | # This is used, if expand_services without convert_hosts. | ||||||
| 10619 | elsif ($type eq 'Host') { | ||||||
| 10620 | 5 | 8 | $result = $obj->{network}->{zone}; | ||||
| 10621 | } | ||||||
| 10622 | else { | ||||||
| 10623 | 0 | 0 | internal_err("unexpected $obj->{name}"); | ||||
| 10624 | } | ||||||
| 10625 | |||||||
| 10626 | # debug("get_path: $obj->{name} -> $result->{name}"); | ||||||
| 10627 | 1147 | 3103 | return($obj2path{$obj} = $result); | ||||
| 10628 | } | ||||||
| 10629 | |||||||
| 10630 | # Converts hash key of reference back to reference. | ||||||
| 10631 | my %key2obj; | ||||||
| 10632 | |||||||
| 10633 | sub cluster_path_mark1; | ||||||
| 10634 | |||||||
| 10635 | sub cluster_path_mark1 { | ||||||
| 10636 | 321 | 0 | 336 | my ($obj, $in_intf, $end, $end_intf, $path_tuples, $loop_leave, $navi) = @_; | |||
| 10637 | 321 | 256 | my $pathrestriction = $in_intf->{path_restrict}; | ||||
| 10638 | 321 | 252 | my $reachable_at = $in_intf->{reachable_at}; | ||||
| 10639 | |||||||
| 10640 | # debug("cluster_path_mark1: obj: $obj->{name}, | ||||||
| 10641 | # in_intf: $in_intf->{name} to: $end->{name}"); | ||||||
| 10642 | |||||||
| 10643 | # Check for second occurrence of path restriction. | ||||||
| 10644 | 321 | 426 | if ($pathrestriction) { | ||||
| 10645 | 53 | 57 | for my $restrict (@$pathrestriction) { | ||||
| 10646 | 40 | 75 | if ($restrict->{active_path}) { | ||||
| 10647 | |||||||
| 10648 | # debug(" effective $restrict->{name} at $in_intf->{name}"); | ||||||
| 10649 | 19 | 54 | return 0; | ||||
| 10650 | } | ||||||
| 10651 | } | ||||||
| 10652 | } | ||||||
| 10653 | |||||||
| 10654 | # Handle optimized pathrestriction. | ||||||
| 10655 | # Check if $end_intf is located outside of current reachable_part. | ||||||
| 10656 | # This must be checked before checking that $end has been reached, | ||||||
| 10657 | 302 | 731 | if ($reachable_at && $end_intf && $end_intf ne $in_intf) { | ||||
| 10658 | 28 | 56 | if (my $reachable = $reachable_at->{$obj}) { | ||||
| 10659 | 28 | 24 | my $other = $end_intf->{zone}; | ||||
| 10660 | |||||||
| 10661 | # $other inside loop | ||||||
| 10662 | 28 | 41 | if ($other->{loop}) { | ||||
| 10663 | 27 | 22 | my $has_mark = $other->{reachable_part}; | ||||
| 10664 | 27 | 31 | for my $mark (@$reachable) { | ||||
| 10665 | 27 | 62 | if (!$has_mark->{$mark}) { | ||||
| 10666 | # debug(" unreachable: $other->{name}", | ||||||
| 10667 | # " from $in_intf->{name} to $obj->{name}"); | ||||||
| 10668 | 10 | 33 | return 0; | ||||
| 10669 | } | ||||||
| 10670 | } | ||||||
| 10671 | } | ||||||
| 10672 | |||||||
| 10673 | # $end_intf at border of loop, $other outside of loop. | ||||||
| 10674 | # In this case, {reachable_part} isn't set at $other. | ||||||
| 10675 | # If partition starting at $in_intf also starts at $end_intf, | ||||||
| 10676 | # then $other can't be reached. | ||||||
| 10677 | else { | ||||||
| 10678 | 1 | 3 | if (my $reachable_at2 = $end_intf->{reachable_at}) { | ||||
| 10679 | 0 | 0 | if (my $reachable2 = $reachable_at2->{$end_intf->{router}}) { | ||||
| 10680 | 0 | 0 | if (intersect($reachable, $reachable2)) { | ||||
| 10681 | # debug(" unreachable2: $other->{name}", | ||||||
| 10682 | # " from $in_intf->{name} to $obj->{name}"); | ||||||
| 10683 | 0 | 0 | return 0; | ||||
| 10684 | } | ||||||
| 10685 | } | ||||||
| 10686 | } | ||||||
| 10687 | } | ||||||
| 10688 | } | ||||||
| 10689 | } | ||||||
| 10690 | |||||||
| 10691 | # Don't walk loops. | ||||||
| 10692 | 292 | 409 | if ($obj->{active_path}) { | ||||
| 10693 | |||||||
| 10694 | # debug(" active: $obj->{name}"); | ||||||
| 10695 | 2 | 5 | return 0; | ||||
| 10696 | } | ||||||
| 10697 | |||||||
| 10698 | # Found a path to router or zone. | ||||||
| 10699 | 290 | 517 | if ($obj eq $end) { | ||||
| 10700 | |||||||
| 10701 | # Mark interface where we leave the loop. | ||||||
| 10702 | 116 | 121 | push @$loop_leave, $in_intf; | ||||
| 10703 | |||||||
| 10704 | # debug(" leave: $in_intf->{name} -> $end->{name}"); | ||||||
| 10705 | 116 | 244 | return 1; | ||||
| 10706 | } | ||||||
| 10707 | |||||||
| 10708 | # Handle optimized pathrestriction. | ||||||
| 10709 | 174 | 234 | if ($reachable_at) { | ||||
| 10710 | 73 | 133 | if (my $reachable = $reachable_at->{$obj}) { | ||||
| 10711 | 70 | 87 | my $end_node = $end_intf ? $end_intf->{zone} : $end; | ||||
| 10712 | 70 | 58 | my $has_mark = $end_node->{reachable_part}; | ||||
| 10713 | 70 | 74 | for my $mark (@$reachable) { | ||||
| 10714 | 70 | 136 | if (!$has_mark->{$mark}) { | ||||
| 10715 | # debug(" unreachable3: $end_node->{name}", | ||||||
| 10716 | # " from $in_intf->{name} to $obj->{name}"); | ||||||
| 10717 | 34 | 104 | return 0; | ||||
| 10718 | } | ||||||
| 10719 | } | ||||||
| 10720 | } | ||||||
| 10721 | } | ||||||
| 10722 | |||||||
| 10723 | # Mark current path for loop detection. | ||||||
| 10724 | 140 | 180 | local $obj->{active_path} = 1; | ||||
| 10725 | # debug "activated $obj->{name}"; | ||||||
| 10726 | |||||||
| 10727 | # Mark first occurrence of path restriction. | ||||||
| 10728 | 140 | 184 | if ($pathrestriction) { | ||||
| 10729 | 13 | 14 | for my $restrict (@$pathrestriction) { | ||||
| 10730 | |||||||
| 10731 | # debug(" enabled $restrict->{name} at $in_intf->{name}"); | ||||||
| 10732 | 13 | 19 | $restrict->{active_path} = 1; | ||||
| 10733 | } | ||||||
| 10734 | } | ||||||
| 10735 | |||||||
| 10736 | 140 | 167 | my $get_next = is_router($obj) ? 'zone' : 'router'; | ||||
| 10737 | 140 | 131 | my $success = 0; | ||||
| 10738 | |||||||
| 10739 | # Fill hash for restoring reference from hash key. | ||||||
| 10740 | 140 | 188 | $key2obj{$in_intf} = $in_intf; | ||||
| 10741 | 140 | 180 | my $allowed = $navi->{ $obj->{loop} }; | ||||
| 10742 | 140 140 | 115 179 | for my $interface (@{ $obj->{interfaces} }) { | ||||
| 10743 | 386 | 717 | next if $interface eq $in_intf; | ||||
| 10744 | |||||||
| 10745 | # As optimization, ignore secondary interface early. | ||||||
| 10746 | 246 | 376 | next if $interface->{main_interface}; | ||||
| 10747 | 188 | 157 | my $loop = $interface->{loop}; | ||||
| 10748 | 188 | 300 | $allowed or internal_err("Loop with empty navigation"); | ||||
| 10749 | 188 | 481 | next if not $loop or not $allowed->{$loop}; | ||||
| 10750 | 172 | 167 | my $next = $interface->{$get_next}; | ||||
| 10751 | # debug "Try $obj->{name} -> $next->{name}"; | ||||||
| 10752 | 172 | 310 | if ( | ||||
| 10753 | cluster_path_mark1( | ||||||
| 10754 | $next, $interface, $end, $end_intf, | ||||||
| 10755 | $path_tuples, $loop_leave, $navi | ||||||
| 10756 | ) | ||||||
| 10757 | ) | ||||||
| 10758 | { | ||||||
| 10759 | |||||||
| 10760 | # Found a valid path from $next to $end. | ||||||
| 10761 | 119 | 148 | $key2obj{$interface} = $interface; | ||||
| 10762 | 119 | 144 | $path_tuples->{$in_intf}->{$interface} = is_router($obj); | ||||
| 10763 | |||||||
| 10764 | # debug(" loop: $in_intf->{name} -> $interface->{name}"); | ||||||
| 10765 | 119 | 214 | $success = 1; | ||||
| 10766 | } | ||||||
| 10767 | } | ||||||
| 10768 | # debug "deactivated $obj->{name}"; | ||||||
| 10769 | 140 | 205 | if ($pathrestriction) { | ||||
| 10770 | 13 | 13 | for my $restrict (@$pathrestriction) { | ||||
| 10771 | |||||||
| 10772 | # debug(" disabled $restrict->{name} at $in_intf->{name}"); | ||||||
| 10773 | 13 | 19 | $restrict->{active_path} = undef; | ||||
| 10774 | } | ||||||
| 10775 | } | ||||||
| 10776 | 140 | 347 | return $success; | ||||
| 10777 | } | ||||||
| 10778 | |||||||
| 10779 | # Optimize navigation inside a cluster of loops. | ||||||
| 10780 | # Mark each loop marker | ||||||
| 10781 | # with the allowed loops to be traversed to reach $to. | ||||||
| 10782 | # The direction is given as a loop object. | ||||||
| 10783 | # It can be used to look up interfaces which reference | ||||||
| 10784 | # this loop object in attribute {loop}. | ||||||
| 10785 | # Return value: | ||||||
| 10786 | # A hash with pairs: object -> loop-marker | ||||||
| 10787 | sub cluster_navigation { | ||||||
| 10788 | 75 | 0 | 73 | my ($from, $to) = @_; | |||
| 10789 | 75 | 71 | my $from_loop = $from->{loop}; | ||||
| 10790 | 75 | 63 | my $to_loop = $to->{loop}; | ||||
| 10791 | |||||||
| 10792 | # debug("Navi: $from->{name}, $to->{name}"); | ||||||
| 10793 | |||||||
| 10794 | 75 | 63 | my $navi; | ||||
| 10795 | 75 | 182 | if (($navi = $from->{navi}->{$to}) and scalar keys %$navi) { | ||||
| 10796 | |||||||
| 10797 | # debug(" Cached"); | ||||||
| 10798 | 3 | 8 | return $navi; | ||||
| 10799 | } | ||||||
| 10800 | 72 | 139 | $navi = $from->{navi}->{$to} = {}; | ||||
| 10801 | |||||||
| 10802 | 72 | 68 | while (1) { | ||||
| 10803 | 135 | 272 | if ($from_loop eq $to_loop) { | ||||
| 10804 | 72 | 158 | last if $from eq $to; | ||||
| 10805 | 11 | 23 | $navi->{$from_loop}->{$from_loop} = 1; | ||||
| 10806 | |||||||
| 10807 | # debug("- Eq: $from_loop->{exit}->{name}$from_loop to itself"); | ||||||
| 10808 | |||||||
| 10809 | # Path $from -> $to traverses $from_loop and $exit_loop. | ||||||
| 10810 | # Inside $exit_loop, enter only $from_loop, but not from other loops. | ||||||
| 10811 | 11 | 13 | my $exit_loop = $from_loop->{exit}->{loop}; | ||||
| 10812 | 11 | 20 | $navi->{$exit_loop}->{$from_loop} = 1; | ||||
| 10813 | |||||||
| 10814 | # debug("- Add $from_loop->{exit}->{name}$from_loop to exit $exit_loop->{exit}->{name}$exit_loop"); | ||||||
| 10815 | 11 | 18 | last; | ||||
| 10816 | } | ||||||
| 10817 | elsif ($from_loop->{distance} >= $to_loop->{distance}) { | ||||||
| 10818 | 18 | 35 | $navi->{$from_loop}->{$from_loop} = 1; | ||||
| 10819 | |||||||
| 10820 | # debug("- Fr: $from_loop->{exit}->{name}$from_loop to itself"); | ||||||
| 10821 | 18 | 20 | $from = $from_loop->{exit}; | ||||
| 10822 | 18 | 22 | $from_loop = $from->{loop}; | ||||
| 10823 | } | ||||||
| 10824 | else { | ||||||
| 10825 | 45 | 99 | $navi->{$to_loop}->{$to_loop} = 1; | ||||
| 10826 | |||||||
| 10827 | # debug("- To: $to_loop->{exit}->{name}$to_loop to itself"); | ||||||
| 10828 | 45 | 53 | $to = $to_loop->{exit}; | ||||
| 10829 | 45 | 37 | my $entry_loop = $to->{loop}; | ||||
| 10830 | 45 | 97 | $navi->{$entry_loop}->{$to_loop} = 1; | ||||
| 10831 | |||||||
| 10832 | # debug("- Add $to_loop->{exit}->{name}$to_loop to entry $entry_loop->{exit}->{name}$entry_loop"); | ||||||
| 10833 | 45 | 54 | $to_loop = $entry_loop; | ||||
| 10834 | } | ||||||
| 10835 | } | ||||||
| 10836 | 72 | 152 | return $navi; | ||||
| 10837 | } | ||||||
| 10838 | |||||||
| 10839 | # Mark paths inside a cluster of loops. | ||||||
| 10840 | # $from and $to are entry and exit objects inside the cluster. | ||||||
| 10841 | # The cluster is entered at interface $from_in and left at interface $to_out. | ||||||
| 10842 | # For each pair of $from / $to, we collect attributes: | ||||||
| 10843 | # {loop_enter}: interfaces of $from, where the cluster is entered, | ||||||
| 10844 | # {path_tuples}: tuples of interfaces, which describe all valid paths, | ||||||
| 10845 | # {loop_leave}: interfaces of $to, where the cluster is left. | ||||||
| 10846 | # Return value is true if a valid path was found. | ||||||
| 10847 | # | ||||||
| 10848 | # $from_store is the starting object of the whole path. | ||||||
| 10849 | # If the path starts at an interface of a loop and it has a pathrestriction attached, | ||||||
| 10850 | # $from_store contains this interface. | ||||||
| 10851 | sub cluster_path_mark { | ||||||
| 10852 | 197 | 0 | 205 | my ($from, $to, $from_in, $to_out, $from_store, $to_store) = @_; | |||
| 10853 | |||||||
| 10854 | # This particular path through this sub-graph is already known. | ||||||
| 10855 | 197 | 362 | return 1 if $from_in->{path}->{$to_store}; | ||||
| 10856 | |||||||
| 10857 | # Start and end interface or undef. | ||||||
| 10858 | # It is set, if the path starts / ends | ||||||
| 10859 | # - at an interface inside the loop or | ||||||
| 10860 | # - at an interface at the border of the loop | ||||||
| 10861 | # (an interface of a router/zone inside the loop) | ||||||
| 10862 | # - this interface has a pathrestriction attached. | ||||||
| 10863 | 197 | 146 | my ($start_intf, $end_intf); | ||||
| 10864 | |||||||
| 10865 | # Check, if loop is entered or left at interface with pathrestriction. | ||||||
| 10866 | # - is $from_store located inside or at border of current loop? | ||||||
| 10867 | # - does $from_in at border of current loop have pathrestriction ? | ||||||
| 10868 | # dito for $to_store and $to_out. | ||||||
| 10869 | 0 | 0 | my ($start_store, $end_store); | ||||
| 10870 | 197 | 234 | if (is_interface($from_store) | ||||
| 10871 | and ($from_store->{router} eq $from or $from_store->{zone} eq $from)) | ||||||
| 10872 | { | ||||||
| 10873 | 37 | 28 | $start_intf = $from_store; | ||||
| 10874 | 37 | 28 | $start_store = $from_store; | ||||
| 10875 | } | ||||||
| 10876 | elsif ($from_in | ||||||
| 10877 | and ($from_in->{path_restrict} or $from_in->{reachable_at})) | ||||||
| 10878 | { | ||||||
| 10879 | 7 | 7 | $start_store = $from_in; | ||||
| 10880 | } | ||||||
| 10881 | else { | ||||||
| 10882 | 153 | 131 | $start_store = $from; | ||||
| 10883 | } | ||||||
| 10884 | 197 | 270 | if (is_interface($to_store) | ||||
| 10885 | and ($to_store->{router} eq $to or $to_store->{zone} eq $to)) | ||||||
| 10886 | { | ||||||
| 10887 | 48 | 37 | $end_intf = $to_store; | ||||
| 10888 | 48 | 40 | $end_store = $to_store; | ||||
| 10889 | } | ||||||
| 10890 | elsif ($to_out and ($to_out->{path_restrict} or $to_out->{reachable_at})) { | ||||||
| 10891 | 2 | 3 | $end_store = $to_out; | ||||
| 10892 | } | ||||||
| 10893 | else { | ||||||
| 10894 | 147 | 121 | $end_store = $to; | ||||
| 10895 | } | ||||||
| 10896 | |||||||
| 10897 | 197 | 177 | my $success = 1; | ||||
| 10898 | 197 | 171 | my $from_interfaces = $from->{interfaces}; | ||||
| 10899 | |||||||
| 10900 | # debug("cluster_path_mark: $start_store->{name} -> $end_store->{name}"); | ||||||
| 10901 | |||||||
| 10902 | # Activate pathrestriction of interface at border of loop, if path starts | ||||||
| 10903 | # or ends outside the loop and enters the loop at such an interface. | ||||||
| 10904 | 197 | 724 | if ( $from_in | ||||
| 10905 | and not $from_in->{loop} | ||||||
| 10906 | and (my $restrictions = $from_in->{path_restrict}) | ||||||
| 10907 | and not $start_intf) | ||||||
| 10908 | { | ||||||
| 10909 | 7 | 9 | for my $restrict (@$restrictions) { | ||||
| 10910 | 7 | 12 | $restrict->{active_path} = 1; | ||||
| 10911 | } | ||||||
| 10912 | } | ||||||
| 10913 | 197 | 417 | if ( $to_out | ||||
| 10914 | and not $to_out->{loop} | ||||||
| 10915 | and (my $restrictions = $to_out->{path_restrict}) | ||||||
| 10916 | and not $end_intf) | ||||||
| 10917 | { | ||||||
| 10918 | 2 | 7 | for my $restrict (@$restrictions) { | ||||
| 10919 | 2 | 6 | if ($restrict->{active_path}) { | ||||
| 10920 | |||||||
| 10921 | # Pathrestriction is applied to both, incoming and outgoing interface. | ||||||
| 10922 | # This prevents traffic through loop. | ||||||
| 10923 | 0 | 0 | $success = 0; | ||||
| 10924 | } | ||||||
| 10925 | 2 | 4 | $restrict->{active_path} = 1; | ||||
| 10926 | } | ||||||
| 10927 | } | ||||||
| 10928 | |||||||
| 10929 | # Check optimized pathrestriction for path starting inside or | ||||||
| 10930 | # outside the loop. | ||||||
| 10931 | REACHABLE: | ||||||
| 10932 | { | ||||||
| 10933 | |||||||
| 10934 | # Check if end node is reachable. | ||||||
| 10935 | # Interface with pathrestriction belongs to zone. | ||||||
| 10936 | 197 197 | 141 253 | my $end_node = $end_intf ? $end_intf->{zone} : $to; | ||||
| 10937 | |||||||
| 10938 | # $start_intf is directly connected to $end_node. | ||||||
| 10939 | # This must be handled as special case, because | ||||||
| 10940 | # optimized pathrestriction doesn't prevent path through router. | ||||||
| 10941 | # Ignore all interfaces except direction to zone. | ||||||
| 10942 | 197 | 380 | if ($start_intf && $start_intf->{zone} eq $end_node) { | ||||
| 10943 | 11 | 14 | $from_interfaces = [ $start_intf ]; | ||||
| 10944 | 11 | 14 | last REACHABLE; | ||||
| 10945 | } | ||||||
| 10946 | |||||||
| 10947 | # If path starts at interface of loop, then ignore restriction | ||||||
| 10948 | # in direction to zone, hence check only the router. | ||||||
| 10949 | 186 | 204 | my $start_node = $start_intf ? $start_intf->{router} : $from; | ||||
| 10950 | 186 | 387 | my $intf = $start_intf || $from_in; | ||||
| 10951 | 186 | 379 | my $reachable_at = $intf->{reachable_at} or last REACHABLE; | ||||
| 10952 | 7 | 13 | my $reachable = $reachable_at->{$start_node} or last REACHABLE; | ||||
| 10953 | 7 | 6 | my $has_mark = $end_node->{reachable_part}; | ||||
| 10954 | 7 | 9 | for my $mark (@$reachable) { | ||||
| 10955 | 7 | 11 | if (!$has_mark->{$mark}) { | ||||
| 10956 | 4 | 5 | if ($start_intf) { | ||||
| 10957 | |||||||
| 10958 | # Ignore all interfaces except direction to zone | ||||||
| 10959 | 4 | 5 | $from_interfaces = [ $start_intf ]; | ||||
| 10960 | } | ||||||
| 10961 | else { | ||||||
| 10962 | 0 | 0 | $success = 0; | ||||
| 10963 | } | ||||||
| 10964 | 4 | 6 | last; | ||||
| 10965 | } | ||||||
| 10966 | } | ||||||
| 10967 | 7 | 21 | if ($success && $start_intf) { | ||||
| 10968 | |||||||
| 10969 | # Temporarily disable optimized pathrestriction in | ||||||
| 10970 | # direction to zone. | ||||||
| 10971 | 7 | 7 | my $zone = $start_intf->{zone}; | ||||
| 10972 | 7 | 19 | $intf->{saved_reachable_at_zone} = delete $reachable_at->{$zone}; | ||||
| 10973 | } | ||||||
| 10974 | } | ||||||
| 10975 | |||||||
| 10976 | # If start / end interface is part of a group of virtual | ||||||
| 10977 | # interfaces (VRRP, HSRP), | ||||||
| 10978 | # prevent traffic through other interfaces of this group. | ||||||
| 10979 | 197 | 209 | for my $intf ($start_intf, $end_intf) { | ||||
| 10980 | 394 | 615 | next if !$intf; | ||||
| 10981 | 85 | 156 | if (my $interfaces = $intf->{redundancy_interfaces}) { | ||||
| 10982 | 25 | 24 | for my $interface (@$interfaces) { | ||||
| 10983 | 50 | 102 | next if $interface eq $intf; | ||||
| 10984 | 25 25 | 20 60 | push @{ $interface->{path_restrict} }, | ||||
| 10985 | $global_active_pathrestriction; | ||||||
| 10986 | } | ||||||
| 10987 | } | ||||||
| 10988 | } | ||||||
| 10989 | |||||||
| 10990 | # Handle special case where path starts or ends at an interface | ||||||
| 10991 | # with pathrestriction. | ||||||
| 10992 | # If the router is left / entered via the same interface, ignore | ||||||
| 10993 | # the PR. If the router is left / entered via some other | ||||||
| 10994 | # interface, add the PR of the start- / end interface to the other | ||||||
| 10995 | # interface. | ||||||
| 10996 | 197 | 210 | for my $intf ($start_intf, $end_intf) { | ||||
| 10997 | 394 | 580 | next if !$intf; | ||||
| 10998 | 85 | 72 | my $router = $intf->{router}; | ||||
| 10999 | 85 | 275 | next if !($router eq $from || $router eq $to); | ||||
| 11000 | 83 | 186 | my $removed = delete $intf->{path_restrict} or next; | ||||
| 11001 | 45 | 48 | $intf->{saved_path_restrict} = $removed; | ||||
| 11002 | 45 45 | 37 59 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 11003 | 161 | 295 | next if $interface eq $intf; | ||||
| 11004 | 116 | 122 | my $orig = | ||||
| 11005 | $interface->{saved_path_restrict} = | ||||||
| 11006 | $interface->{path_restrict}; | ||||||
| 11007 | 116 | 121 | if ($orig) { | ||||
| 11008 | 3 | 6 | if (intersect($orig, $removed)) { | ||||
| 11009 | 3 | 11 | $interface->{path_restrict} = | ||||
| 11010 | [ $global_active_pathrestriction ]; | ||||||
| 11011 | } | ||||||
| 11012 | else { | ||||||
| 11013 | 0 | 0 | $interface->{path_restrict} = [ @$orig, @$removed ]; | ||||
| 11014 | } | ||||||
| 11015 | } | ||||||
| 11016 | else { | ||||||
| 11017 | 113 | 161 | $interface->{path_restrict} = $removed; | ||||
| 11018 | } | ||||||
| 11019 | } | ||||||
| 11020 | } | ||||||
| 11021 | |||||||
| 11022 | BLOCK: | ||||||
| 11023 | { | ||||||
| 11024 | 197 197 | 178 267 | last BLOCK if not $success; | ||||
| 11025 | 197 | 152 | $success = 0; | ||||
| 11026 | |||||||
| 11027 | 197 | 325 | $from_in->{loop_entry}->{$to_store} = $start_store; | ||||
| 11028 | 197 | 279 | $start_store->{loop_exit}->{$to_store} = $end_store; | ||||
| 11029 | |||||||
| 11030 | # Path from $start_store to $end_store inside cyclic graph | ||||||
| 11031 | # has been marked already. | ||||||
| 11032 | 197 | 383 | if ($start_store->{loop_enter}->{$end_store}) { | ||||
| 11033 | 122 | 92 | $success = 1; | ||||
| 11034 | 122 | 134 | last BLOCK; | ||||
| 11035 | } | ||||||
| 11036 | |||||||
| 11037 | 75 | 84 | my $loop_enter = []; | ||||
| 11038 | 75 | 83 | my $path_tuples = {}; | ||||
| 11039 | 75 | 70 | my $loop_leave = []; | ||||
| 11040 | |||||||
| 11041 | 75 | 104 | my $navi = cluster_navigation($from, $to) | ||||
| 11042 | or internal_err("Empty navi"); | ||||||
| 11043 | |||||||
| 11044 | # use Dumpvalue; | ||||||
| 11045 | # Dumpvalue->new->dumpValue($navi); | ||||||
| 11046 | |||||||
| 11047 | # Mark current path for loop detection. | ||||||
| 11048 | 75 | 120 | local $from->{active_path} = 1; | ||||
| 11049 | 75 | 97 | my $get_next = is_router($from) ? 'zone' : 'router'; | ||||
| 11050 | 75 | 171 | my $allowed = $navi->{ $from->{loop} } | ||||
| 11051 | or internal_err("Loop $from->{loop}->{exit}->{name}$from->{loop}", | ||||||
| 11052 | " with empty navi"); | ||||||
| 11053 | 75 | 91 | for my $interface (@$from_interfaces) { | ||||
| 11054 | 220 | 340 | next if $interface->{main_interface}; | ||||
| 11055 | 184 | 156 | my $loop = $interface->{loop}; | ||||
| 11056 | 184 | 270 | next if not $loop; | ||||
| 11057 | 151 | 266 | if (not $allowed->{$loop}) { | ||||
| 11058 | |||||||
| 11059 | # debug("No: $loop->{exit}->{name}$loop"); | ||||||
| 11060 | 2 | 3 | next; | ||||
| 11061 | } | ||||||
| 11062 | |||||||
| 11063 | # Don't enter network which connects pair of virtual loopback | ||||||
| 11064 | # interfaces. | ||||||
| 11065 | 149 | 248 | next if $interface->{loopback} and $get_next eq 'zone'; | ||||
| 11066 | 149 | 145 | my $next = $interface->{$get_next}; | ||||
| 11067 | |||||||
| 11068 | # debug(" try: $from->{name} -> $interface->{name}"); | ||||||
| 11069 | 149 | 196 | if ( | ||||
| 11070 | cluster_path_mark1( | ||||||
| 11071 | $next, $interface, $to, $end_intf, | ||||||
| 11072 | $path_tuples, $loop_leave, $navi | ||||||
| 11073 | ) | ||||||
| 11074 | ) | ||||||
| 11075 | { | ||||||
| 11076 | 114 | 87 | $success = 1; | ||||
| 11077 | 114 | 172 | push @$loop_enter, $interface; | ||||
| 11078 | |||||||
| 11079 | # debug(" enter: $from->{name} -> $interface->{name}"); | ||||||
| 11080 | } | ||||||
| 11081 | } | ||||||
| 11082 | |||||||
| 11083 | # Don't store incomplete result. | ||||||
| 11084 | 75 | 122 | last BLOCK if not $success; | ||||
| 11085 | |||||||
| 11086 | # Convert { intf->intf->node_type } to [ intf, intf, node_type ] | ||||||
| 11087 | 73 | 78 | my $tuples_aref = []; | ||||
| 11088 | 73 | 145 | for my $in_intf_ref (keys %$path_tuples) { | ||||
| 11089 | 115 | 171 | my $in_intf = $key2obj{$in_intf_ref} | ||||
| 11090 | or internal_err("Unknown in_intf at tuple"); | ||||||
| 11091 | 115 | 105 | my $hash = $path_tuples->{$in_intf_ref}; | ||||
| 11092 | 115 | 162 | for my $out_intf_ref (keys %$hash) { | ||||
| 11093 | 119 | 180 | my $out_intf = $key2obj{$out_intf_ref} | ||||
| 11094 | or internal_err("Unknown out_intf at tuple"); | ||||||
| 11095 | 119 | 113 | my $at_router = $hash->{$out_intf_ref}; | ||||
| 11096 | 119 | 344 | push @$tuples_aref, [ $in_intf, $out_intf, $at_router ]; | ||||
| 11097 | |||||||
| 11098 | # debug("Tuple: $in_intf->{name}, $out_intf->{name} $at_router"); | ||||||
| 11099 | } | ||||||
| 11100 | } | ||||||
| 11101 | |||||||
| 11102 | # Remove duplicates, which occur from nested loops.. | ||||||
| 11103 | 73 | 116 | $loop_leave = [ unique(@$loop_leave) ]; | ||||
| 11104 | |||||||
| 11105 | 73 | 137 | $start_store->{loop_enter}->{$end_store} = $loop_enter; | ||||
| 11106 | 73 | 125 | $start_store->{loop_leave}->{$end_store} = $loop_leave; | ||||
| 11107 | 73 | 111 | $start_store->{path_tuples}->{$end_store} = $tuples_aref; | ||||
| 11108 | |||||||
| 11109 | # Add data for reverse path. | ||||||
| 11110 | 73 | 116 | $end_store->{loop_enter}->{$start_store} = $loop_leave; | ||||
| 11111 | 73 | 110 | $end_store->{loop_leave}->{$start_store} = $loop_enter; | ||||
| 11112 | 119 | 431 | $end_store->{path_tuples}->{$start_store} = | ||||
| 11113 | 73 119 | 148 96 | [ map { [ @{$_}[ 1, 0, 2 ] ] } @$tuples_aref ]; | ||||
| 11114 | } | ||||||
| 11115 | |||||||
| 11116 | # Restore temporarily changed path restrictions. | ||||||
| 11117 | 197 | 223 | for my $intf ($start_intf, $end_intf) { | ||||
| 11118 | 394 | 614 | next if !$intf; | ||||
| 11119 | 85 | 141 | next if !$intf->{saved_path_restrict}; | ||||
| 11120 | 45 | 41 | my $router = $intf->{router}; | ||||
| 11121 | 45 45 | 37 56 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 11122 | 161 | 216 | if (my $orig = delete $interface->{saved_path_restrict}) { | ||||
| 11123 | 48 | 79 | $interface->{path_restrict} = $orig ; | ||||
| 11124 | } | ||||||
| 11125 | else { | ||||||
| 11126 | 113 | 148 | delete $interface->{path_restrict}; | ||||
| 11127 | } | ||||||
| 11128 | } | ||||||
| 11129 | } | ||||||
| 11130 | 197 | 286 | if ($start_intf) { | ||||
| 11131 | 37 | 69 | if (my $orig = delete $start_intf->{saved_reachable_at_zone}) { | ||||
| 11132 | 7 | 7 | my $zone = $start_intf->{zone}; | ||||
| 11133 | 7 | 15 | $start_intf->{reachable_at}->{$zone} = $orig; | ||||
| 11134 | } | ||||||
| 11135 | } | ||||||
| 11136 | 197 | 187 | for my $intf ($start_intf, $end_intf) { | ||||
| 11137 | 394 | 569 | next if !$intf; | ||||
| 11138 | 85 | 149 | if (my $interfaces = $intf->{redundancy_interfaces}) { | ||||
| 11139 | 25 | 25 | for my $interface (@$interfaces) { | ||||
| 11140 | 50 | 103 | next if $interface eq $intf; | ||||
| 11141 | 25 25 | 18 49 | pop @{ $interface->{path_restrict} }; | ||||
| 11142 | } | ||||||
| 11143 | } | ||||||
| 11144 | } | ||||||
| 11145 | |||||||
| 11146 | # Disable pathrestriction at border of loop. | ||||||
| 11147 | 197 | 197 | for my $intf ($from_in, $to_out) { | ||||
| 11148 | 394 | 1212 | if ( $intf | ||||
| 11149 | and not $intf->{loop} | ||||||
| 11150 | and (my $restrictions = $intf->{path_restrict})) | ||||||
| 11151 | { | ||||||
| 11152 | 11 | 11 | for my $restrict (@$restrictions) { | ||||
| 11153 | 13 | 24 | $restrict->{active_path} = 0; | ||||
| 11154 | } | ||||||
| 11155 | } | ||||||
| 11156 | } | ||||||
| 11157 | 197 | 296 | if ($success) { | ||||
| 11158 | |||||||
| 11159 | # When entering sub-graph at $from_in we will leave it at $to_out. | ||||||
| 11160 | 195 | 314 | $from_in->{path}->{$to_store} = $to_out; | ||||
| 11161 | } | ||||||
| 11162 | 197 | 572 | return $success; | ||||
| 11163 | } | ||||||
| 11164 | |||||||
| 11165 | # Mark path from $from to $to. | ||||||
| 11166 | # $from and $to are either a router or a zone. | ||||||
| 11167 | # For a path without loops, $from_store equals $from and $to_store equals $to. | ||||||
| 11168 | # If the path starts at an interface inside a cluster of loops | ||||||
| 11169 | # or at the border of a cluster, | ||||||
| 11170 | # and the interface has a pathrestriction attached, | ||||||
| 11171 | # then $from_store contains this interface. | ||||||
| 11172 | # If the path ends at an interface inside a loop or at the border of a loop, | ||||||
| 11173 | # $to_store contains this interface. | ||||||
| 11174 | # At each interface on the path from $from to $to, | ||||||
| 11175 | # we place a reference to the next interface on the path to $to_store. | ||||||
| 11176 | # This reference is found in a hash at attribute {path}. | ||||||
| 11177 | # Additionally we attach the path attribute to the src object. | ||||||
| 11178 | # Return value is true if a valid path was found. | ||||||
| 11179 | sub path_mark { | ||||||
| 11180 | 519 | 0 | 540 | my ($from, $to, $from_store, $to_store) = @_; | |||
| 11181 | |||||||
| 11182 | # debug("path_mark $from_store->{name} --> $to_store->{name}"); | ||||||
| 11183 | |||||||
| 11184 | 519 | 464 | my $from_loop = $from->{loop}; | ||||
| 11185 | 519 | 474 | my $to_loop = $to->{loop}; | ||||
| 11186 | |||||||
| 11187 | # $from_store and $from differ if path starts at an interface | ||||||
| 11188 | # with pathrestriction. | ||||||
| 11189 | # Inside a loop, use $from_store, not $from, | ||||||
| 11190 | # because the path may differ depending on the start interface. | ||||||
| 11191 | # But outside a loop (pathrestriction is allowed at the border of a loop) | ||||||
| 11192 | # we have only a single path which enters the loop. | ||||||
| 11193 | # In this case we must not use the interface but the router, | ||||||
| 11194 | # otherwise we would get an invalid {path}: | ||||||
| 11195 | # $from_store->{path}->{$to_store} = $from_store; | ||||||
| 11196 | 519 | 644 | my $from_in = $from_store->{loop} ? $from_store : $from; | ||||
| 11197 | 519 | 399 | my $to_out = undef; | ||||
| 11198 | 519 | 394 | while (1) { | ||||
| 11199 | |||||||
| 11200 | # debug("Dist: $from->{distance} $from->{name} ->Dist: $to->{distance} $to->{name}"); | ||||||
| 11201 | # Paths meet outside a loop or at the edge of a loop. | ||||||
| 11202 | 1356 | 2314 | if ($from eq $to) { | ||||
| 11203 | |||||||
| 11204 | # debug(" $from_in->{name} -> ".($to_out ? $to_out->{name}:'')); | ||||||
| 11205 | 326 | 464 | $from_in->{path}->{$to_store} = $to_out; | ||||
| 11206 | 326 | 760 | return 1; | ||||
| 11207 | } | ||||||
| 11208 | |||||||
| 11209 | # Paths meet inside a loop. | ||||||
| 11210 | 1030 | 2235 | if ( $from_loop | ||||
| 11211 | && $to_loop | ||||||
| 11212 | && $from_loop->{cluster_exit} eq $to_loop->{cluster_exit}) | ||||||
| 11213 | { | ||||||
| 11214 | 184 | 250 | return cluster_path_mark($from, $to, $from_in, $to_out, $from_store, | ||||
| 11215 | $to_store); | ||||||
| 11216 | } | ||||||
| 11217 | |||||||
| 11218 | 846 | 1175 | if ($from->{distance} >= $to->{distance}) { | ||||
| 11219 | |||||||
| 11220 | # Mark has already been set for a sub-path. | ||||||
| 11221 | 365 | 676 | return 1 if $from_in->{path}->{$to_store}; | ||||
| 11222 | 358 | 318 | my $from_out = $from->{main}; | ||||
| 11223 | 358 | 487 | unless ($from_out) { | ||||
| 11224 | |||||||
| 11225 | # Reached border of partition. | ||||||
| 11226 | 7 | 18 | return 0 if !$from_loop; | ||||
| 11227 | |||||||
| 11228 | # $from_loop references object which is loop's exit. | ||||||
| 11229 | 7 | 7 | my $exit = $from_loop->{cluster_exit}; | ||||
| 11230 | 7 | 7 | $from_out = $exit->{main}; | ||||
| 11231 | |||||||
| 11232 | # Reached border of partition. | ||||||
| 11233 | 7 | 11 | return 0 if !$from_out; | ||||
| 11234 | |||||||
| 11235 | 7 | 11 | cluster_path_mark($from, $exit, $from_in, $from_out, | ||||
| 11236 | $from_store, $to_store) | ||||||
| 11237 | or return 0; | ||||||
| 11238 | } | ||||||
| 11239 | |||||||
| 11240 | # debug(" $from_in->{name} -> ".($from_out ? $from_out->{name}:'')); | ||||||
| 11241 | 358 | 529 | $from_in->{path}->{$to_store} = $from_out; | ||||
| 11242 | 358 | 284 | $from_in = $from_out; | ||||
| 11243 | 358 | 308 | $from = $from_out->{main}; | ||||
| 11244 | 358 | 425 | $from_loop = $from->{loop}; | ||||
| 11245 | } | ||||||
| 11246 | else { | ||||||
| 11247 | 481 | 405 | my $to_in = $to->{main}; | ||||
| 11248 | 481 | 670 | unless ($to_in) { | ||||
| 11249 | |||||||
| 11250 | # Reached border of partition. | ||||||
| 11251 | 8 | 16 | return 0 if !$to_loop; | ||||
| 11252 | |||||||
| 11253 | 6 | 8 | my $entry = $to_loop->{cluster_exit}; | ||||
| 11254 | 6 | 6 | $to_in = $entry->{main}; | ||||
| 11255 | |||||||
| 11256 | # Reached border of partition. | ||||||
| 11257 | 6 | 8 | return 0 if !$to_in; | ||||
| 11258 | |||||||
| 11259 | 6 | 9 | cluster_path_mark($entry, $to, $to_in, $to_out, $from_store, | ||||
| 11260 | $to_store) | ||||||
| 11261 | or return 0; | ||||||
| 11262 | } | ||||||
| 11263 | |||||||
| 11264 | # debug(" $to_in->{name} -> ".($to_out ? $to_out->{name}:'')); | ||||||
| 11265 | 479 | 753 | $to_in->{path}->{$to_store} = $to_out; | ||||
| 11266 | 479 | 359 | $to_out = $to_in; | ||||
| 11267 | 479 | 406 | $to = $to_in->{main}; | ||||
| 11268 | 479 | 525 | $to_loop = $to->{loop}; | ||||
| 11269 | } | ||||||
| 11270 | } | ||||||
| 11271 | 0 | 0 | return 0; # unused; only for perlcritic | ||||
| 11272 | } | ||||||
| 11273 | |||||||
| 11274 | # Walk paths inside cyclic graph | ||||||
| 11275 | sub loop_path_walk { | ||||||
| 11276 | 271 | 0 | 352 | my ($in, $out, $loop_entry, $loop_exit, $call_at_zone, $rule, $fun) = @_; | |||
| 11277 | |||||||
| 11278 | # my $info = "loop_path_walk: "; | ||||||
| 11279 | # $info .= "$in->{name}->" if $in; | ||||||
| 11280 | # $info .= "$loop_entry->{name}=>$loop_exit->{name}"; | ||||||
| 11281 | # $info .= "->$out->{name}" if $out; | ||||||
| 11282 | # debug($info); | ||||||
| 11283 | |||||||
| 11284 | # Process entry of cyclic graph. | ||||||
| 11285 | 271 | 298 | if ( | ||||
| 11286 | ( | ||||||
| 11287 | is_router($loop_entry) | ||||||
| 11288 | or | ||||||
| 11289 | |||||||
| 11290 | # $loop_entry is interface with pathrestriction of original | ||||||
| 11291 | # loop_entry. | ||||||
| 11292 | is_interface($loop_entry) | ||||||
| 11293 | and | ||||||
| 11294 | |||||||
| 11295 | # Take only interface which originally was a router. | ||||||
| 11296 | $loop_entry->{router} eq | ||||||
| 11297 | $loop_entry->{loop_enter}->{$loop_exit}->[0]->{router} | ||||||
| 11298 | ) xor $call_at_zone | ||||||
| 11299 | ) | ||||||
| 11300 | { | ||||||
| 11301 | |||||||
| 11302 | # debug(" loop_enter"); | ||||||
| 11303 | 105 105 | 85 198 | for my $out_intf (@{ $loop_entry->{loop_enter}->{$loop_exit} }) { | ||||
| 11304 | 155 | 200 | $fun->($rule, $in, $out_intf); | ||||
| 11305 | } | ||||||
| 11306 | } | ||||||
| 11307 | |||||||
| 11308 | # Process paths inside cyclic graph. | ||||||
| 11309 | 271 | 445 | my $path_tuples = $loop_entry->{path_tuples}->{$loop_exit}; | ||||
| 11310 | |||||||
| 11311 | # debug(" loop_tuples"); | ||||||
| 11312 | 271 | 305 | for my $tuple (@$path_tuples) { | ||||
| 11313 | 406 | 403 | my ($in_intf, $out_intf, $at_router) = @$tuple; | ||||
| 11314 | 406 | 1312 | $fun->($rule, $in_intf, $out_intf) | ||||
| 11315 | if $at_router xor $call_at_zone; | ||||||
| 11316 | } | ||||||
| 11317 | |||||||
| 11318 | # Process paths at exit of cyclic graph. | ||||||
| 11319 | 271 | 340 | my $exit_at_router = | ||||
| 11320 | is_router($loop_exit) | ||||||
| 11321 | || (is_interface($loop_exit) | ||||||
| 11322 | && $loop_exit->{router} eq | ||||||
| 11323 | $loop_entry->{loop_leave}->{$loop_exit}->[0]->{router}); | ||||||
| 11324 | 271 | 804 | if ($exit_at_router xor $call_at_zone) { | ||||
| 11325 | |||||||
| 11326 | # debug(" loop_leave"); | ||||||
| 11327 | 165 165 | 125 307 | for my $in_intf (@{ $loop_entry->{loop_leave}->{$loop_exit} }) { | ||||
| 11328 | 243 | 286 | $fun->($rule, $in_intf, $out); | ||||
| 11329 | } | ||||||
| 11330 | } | ||||||
| 11331 | 271 | 466 | return $exit_at_router; | ||||
| 11332 | } | ||||||
| 11333 | |||||||
| 11334 | # Apply a function to a rule at every router or zone on the path from | ||||||
| 11335 | # src to dst of the rule. | ||||||
| 11336 | # $where tells, where the function gets called: at 'Router' or 'Zone'. | ||||||
| 11337 | # Default is 'Router'. | ||||||
| 11338 | sub path_walk { | ||||||
| 11339 | 1467 | 0 | 1452 | my ($rule, $fun, $where) = @_; | |||
| 11340 | 1467 | 2096 | internal_err("undefined rule") unless $rule; | ||||
| 11341 | 1467 | 1285 | my $src = $rule->{src}; | ||||
| 11342 | 1467 | 1211 | my $dst = $rule->{dst}; | ||||
| 11343 | |||||||
| 11344 | 1467 | 3091 | my $from_store = $obj2path{$src} || get_path $src; | ||||
| 11345 | 1467 | 2857 | my $to_store = $obj2path{$dst} || get_path $dst; | ||||
| 11346 | 1467 | 3466 | my $from = $from_store->{router} || $from_store; | ||||
| 11347 | 1467 | 3168 | my $to = $to_store->{router} || $to_store; | ||||
| 11348 | 1467 | 1788 | my $path_store = $from_store->{loop} ? $from_store : $from; | ||||
| 11349 | |||||||
| 11350 | # debug(print_rule $rule); | ||||||
| 11351 | # debug(" start: $from->{name}, $to->{name}" . ($where?", at $where":'')); | ||||||
| 11352 | # my $fun2 = $fun; | ||||||
| 11353 | # $fun = sub { | ||||||
| 11354 | # my($rule, $in, $out) = @_; | ||||||
| 11355 | # my $in_name = $in?$in->{name}:'-'; | ||||||
| 11356 | # my $out_name = $out?$out->{name}:'-'; | ||||||
| 11357 | # debug(" Walk: $in_name, $out_name"); | ||||||
| 11358 | # $fun2->(@_); | ||||||
| 11359 | # }; | ||||||
| 11360 | 1467 | 4090 | $from and $to or internal_err(print_rule $rule); | ||||
| 11361 | 1467 | 2626 | $from eq $to and internal_err("Unenforceable:\n ", print_rule $rule); | ||||
| 11362 | |||||||
| 11363 | 1467 | 2753 | if (!$path_store->{path}->{$to_store}) { | ||||
| 11364 | 495 | 704 | if (!path_mark($from, $to, $from_store, $to_store)) { | ||||
| 11365 | 4 | 13 | err_msg("No valid path\n", | ||||
| 11366 | " from $from_store->{name}\n", | ||||||
| 11367 | " to $to_store->{name}\n", | ||||||
| 11368 | " for rule ", print_rule($rule), "\n", | ||||||
| 11369 | " Check path restrictions and crypto interfaces."); | ||||||
| 11370 | 4 | 10 | delete $path_store->{path}->{$to_store}; | ||||
| 11371 | 4 | 12 | return; | ||||
| 11372 | } | ||||||
| 11373 | } | ||||||
| 11374 | 1463 | 1170 | my $in = undef; | ||||
| 11375 | 1463 | 1054 | my $out; | ||||
| 11376 | 1463 | 3018 | my $at_zone = $where && $where eq 'Zone'; | ||||
| 11377 | 1463 | 1730 | my $call_it = (is_router($from) xor $at_zone); | ||||
| 11378 | |||||||
| 11379 | # Path starts inside a cyclic graph | ||||||
| 11380 | # or at interface of router inside cyclic graph. | ||||||
| 11381 | 1463 | 3919 | if ($from->{loop} | ||||
| 11382 | and $from_store->{loop_exit} | ||||||
| 11383 | and my $loop_exit = $from_store->{loop_exit}->{$to_store}) | ||||||
| 11384 | { | ||||||
| 11385 | 201 | 259 | my $loop_out = $path_store->{path}->{$to_store}; | ||||
| 11386 | 201 | 239 | my $exit_at_router = | ||||
| 11387 | loop_path_walk($in, $loop_out, $from_store, $loop_exit, $at_zone, | ||||||
| 11388 | $rule, $fun); | ||||||
| 11389 | 201 | 302 | if (not $loop_out) { | ||||
| 11390 | |||||||
| 11391 | # debug("exit: path_walk: dst in loop"); | ||||||
| 11392 | 143 | 343 | return; | ||||
| 11393 | } | ||||||
| 11394 | |||||||
| 11395 | # Continue behind loop. | ||||||
| 11396 | 58 | 151 | $call_it = not($exit_at_router xor $at_zone); | ||||
| 11397 | 58 | 46 | $in = $loop_out; | ||||
| 11398 | 58 | 102 | $out = $in->{path}->{$to_store}; | ||||
| 11399 | } | ||||||
| 11400 | else { | ||||||
| 11401 | 1262 | 1882 | $out = $path_store->{path}->{$to_store}; | ||||
| 11402 | } | ||||||
| 11403 | 1320 | 977 | while (1) { | ||||
| 11404 | 4411 | 12403 | if ( $in | ||||
| 11405 | and $in->{loop_entry} | ||||||
| 11406 | and my $loop_entry = $in->{loop_entry}->{$to_store}) | ||||||
| 11407 | { | ||||||
| 11408 | 70 | 92 | my $loop_exit = $loop_entry->{loop_exit}->{$to_store}; | ||||
| 11409 | 70 | 83 | my $loop_out = $in->{path}->{$to_store}; | ||||
| 11410 | 70 | 88 | my $exit_at_router = | ||||
| 11411 | loop_path_walk($in, $loop_out, $loop_entry, $loop_exit, | ||||||
| 11412 | $at_zone, $rule, $fun); | ||||||
| 11413 | 70 | 95 | if (not $loop_out) { | ||||
| 11414 | |||||||
| 11415 | # debug("exit: path_walk: reached dst in loop"); | ||||||
| 11416 | 52 | 126 | return; | ||||
| 11417 | } | ||||||
| 11418 | 18 | 50 | $call_it = not($exit_at_router xor $at_zone); | ||||
| 11419 | 18 | 15 | $in = $loop_out; | ||||
| 11420 | 18 | 34 | $out = $in->{path}->{$to_store}; | ||||
| 11421 | } | ||||||
| 11422 | else { | ||||||
| 11423 | 4341 | 5567 | if ($call_it) { | ||||
| 11424 | 1858 | 2290 | $fun->($rule, $in, $out); | ||||
| 11425 | } | ||||||
| 11426 | |||||||
| 11427 | # End of path has been reached. | ||||||
| 11428 | 4341 | 5602 | if (not $out) { | ||||
| 11429 | |||||||
| 11430 | # debug("exit: path_walk: reached dst"); | ||||||
| 11431 | 1268 | 2871 | return; | ||||
| 11432 | } | ||||||
| 11433 | 3073 | 2736 | $call_it = !$call_it; | ||||
| 11434 | 3073 | 2266 | $in = $out; | ||||
| 11435 | 3073 | 4418 | $out = $in->{path}->{$to_store}; | ||||
| 11436 | } | ||||||
| 11437 | } | ||||||
| 11438 | 0 | 0 | return; | ||||
| 11439 | } | ||||||
| 11440 | |||||||
| 11441 | my %border2obj2auto; | ||||||
| 11442 | |||||||
| 11443 | sub set_auto_intf_from_border { | ||||||
| 11444 | 10 | 0 | 11 | my ($border) = @_; | |||
| 11445 | 10 | 7 | my %active_path; | ||||
| 11446 | my $reach_from_border; | ||||||
| 11447 | $reach_from_border = sub { | ||||||
| 11448 | 74 | 67 | my ($network, $in_intf, $result) = @_; | ||||
| 11449 | 74 | 86 | $active_path{$network} = 1; | ||||
| 11450 | 74 | 123 | $result->{$network}->{$in_intf} = $in_intf; | ||||
| 11451 | # debug "$network->{name}: $in_intf->{name}"; | ||||||
| 11452 | 74 74 | 47 92 | for my $interface (@{ $network->{interfaces} }) { | ||||
| 11453 | 153 | 282 | next if $interface eq $in_intf; | ||||
| 11454 | 79 | 101 | next if $interface->{zone}; | ||||
| 11455 | 73 | 110 | next if $interface->{orig_main}; | ||||
| 11456 | 61 | 43 | my $router = $interface->{router}; | ||||
| 11457 | 61 | 115 | next if $active_path{$router}; | ||||
| 11458 | 39 | 43 | $active_path{$router} = 1; | ||||
| 11459 | 39 | 62 | $result->{$router}->{$interface} = $interface; | ||||
| 11460 | # debug "$router->{name}: $interface->{name}"; | ||||||
| 11461 | |||||||
| 11462 | 39 39 | 27 62 | for my $out_intf (@{ $router->{interfaces} }) { | ||||
| 11463 | 115 | 202 | next if $out_intf eq $interface; | ||||
| 11464 | 76 | 99 | next if $out_intf->{orig_main}; | ||||
| 11465 | 64 | 60 | my $out_net = $out_intf->{network}; | ||||
| 11466 | 64 | 81 | $reach_from_border->($out_net, $out_intf, $result); | ||||
| 11467 | } | ||||||
| 11468 | 39 | 68 | $active_path{$router} = 0; | ||||
| 11469 | } | ||||||
| 11470 | 74 | 141 | $active_path{$network} = 0; | ||||
| 11471 | 10 | 37 | }; | ||||
| 11472 | 10 | 14 | my $result = {}; | ||||
| 11473 | 10 | 14 | $reach_from_border->($border->{network}, $border, $result); | ||||
| 11474 | 10 | 20 | for my $href (values %$result) { | ||||
| 11475 | 42 | 90 | $href = [ values %$href ]; | ||||
| 11476 | } | ||||||
| 11477 | 10 | 17 | $border2obj2auto{$border} = $result; | ||||
| 11478 | 10 | 16 | return; | ||||
| 11479 | } | ||||||
| 11480 | |||||||
| 11481 | # $src is an auto_interface, interface or router. | ||||||
| 11482 | # Result is the set of interfaces of $src located at the front side | ||||||
| 11483 | # of the direction to $dst. | ||||||
| 11484 | sub path_auto_interfaces { | ||||||
| 11485 | 55 | 0 | 55 | my ($src, $dst) = @_; | |||
| 11486 | 55 | 37 | my @result; | ||||
| 11487 | 52 | 74 | my ($src2, $managed) = | ||||
| 11488 | is_autointerface($src) | ||||||
| 11489 | 55 | 66 | ? @{$src}{ 'object', 'managed' } | ||||
| 11490 | : ($src, undef); | ||||||
| 11491 | 55 | 70 | my $dst2 = is_autointerface($dst) ? $dst->{object} : $dst; | ||||
| 11492 | |||||||
| 11493 | 55 | 153 | my $from_store = $obj2path{$src2} || get_path $src2; | ||||
| 11494 | 55 | 125 | my $to_store = $obj2path{$dst2} || get_path $dst2; | ||||
| 11495 | 55 | 149 | my $from = $from_store->{router} || $from_store; | ||||
| 11496 | 55 | 131 | my $to = $to_store->{router} || $to_store; | ||||
| 11497 | |||||||
| 11498 | 55 | 105 | $from eq $to and return (); | ||||
| 11499 | 53 | 106 | if (!$from_store->{path}->{$to_store}) { | ||||
| 11500 | 24 | 37 | if (!path_mark($from, $to, $from_store, $to_store)) { | ||||
| 11501 | 0 | 0 | err_msg("No valid path\n", | ||||
| 11502 | " from $from_store->{name}\n", | ||||||
| 11503 | " to $to_store->{name}\n", | ||||||
| 11504 | " while resolving $src->{name}", | ||||||
| 11505 | " (destination is $dst->{name}).\n", | ||||||
| 11506 | " Check path restrictions and crypto interfaces."); | ||||||
| 11507 | 0 | 0 | delete $from_store->{path}->{$to_store}; | ||||
| 11508 | 0 | 0 | return; | ||||
| 11509 | } | ||||||
| 11510 | } | ||||||
| 11511 | 53 | 122 | if ($from_store->{loop_exit} | ||||
| 11512 | and my $exit = $from_store->{loop_exit}->{$to_store}) | ||||||
| 11513 | { | ||||||
| 11514 | 9 9 | 7 22 | @result = @{ $from->{loop_enter}->{$exit} }; | ||||
| 11515 | } | ||||||
| 11516 | else { | ||||||
| 11517 | 44 | 76 | @result = ($from_store->{path}->{$to_store}); | ||||
| 11518 | } | ||||||
| 11519 | 53 62 | 53 129 | @result = grep { $_->{ip} ne 'tunnel' } @result; | ||||
| 11520 | |||||||
| 11521 | # Find auto interface inside zone. | ||||||
| 11522 | # $src is located inside some zone. | ||||||
| 11523 | # $src2 is known to be unmanaged router or network. | ||||||
| 11524 | 53 | 68 | if (!is_router($from)) { | ||||
| 11525 | 34 | 26 | my %result; | ||||
| 11526 | 34 | 36 | for my $border (@result) { | ||||
| 11527 | 40 | 78 | if (not $border2obj2auto{$border}) { | ||||
| 11528 | 10 | 14 | set_auto_intf_from_border($border); | ||||
| 11529 | } | ||||||
| 11530 | 40 | 60 | my $auto_intf = $border2obj2auto{$border}->{$src2}; | ||||
| 11531 | 40 | 41 | for my $interface (@$auto_intf) { | ||||
| 11532 | 60 | 128 | $result{$interface} = $interface; | ||||
| 11533 | } | ||||||
| 11534 | } | ||||||
| 11535 | 34 | 84 | @result = sort by_name values %result; | ||||
| 11536 | } | ||||||
| 11537 | |||||||
| 11538 | 53 | 50 | my $bridged_count = 0; | ||||
| 11539 | 53 | 54 | for my $interface (@result) { | ||||
| 11540 | |||||||
| 11541 | # If device has virtual interface, main and virtual interface | ||||||
| 11542 | # are swapped. Swap it back here because we need the | ||||||
| 11543 | # original main interface if an interface is used in a rule. | ||||||
| 11544 | 80 | 218 | if (my $orig = $interface->{orig_main}) { | ||||
| 11545 | 0 | 0 | $interface = $orig; | ||||
| 11546 | } | ||||||
| 11547 | |||||||
| 11548 | # Change bridge interface to layer3 interface. | ||||||
| 11549 | # Prevent duplicate layer3 interface. | ||||||
| 11550 | elsif (my $layer3_intf = $interface->{layer3_interface}) { | ||||||
| 11551 | 2 | 2 | $interface = $layer3_intf; | ||||
| 11552 | 2 | 3 | $bridged_count++; | ||||
| 11553 | } | ||||||
| 11554 | } | ||||||
| 11555 | 53 | 84 | if ($bridged_count > 1) { | ||||
| 11556 | 0 | 0 | @result = unique(@result); | ||||
| 11557 | } | ||||||
| 11558 | |||||||
| 11559 | # debug("$src2->{name}.[auto] = ", join ',', map {$_->{name}} @result); | ||||||
| 11560 | 53 0 | 144 0 | return($managed ? grep { $_->{router}->{managed} } @result : @result); | ||||
| 11561 | } | ||||||
| 11562 | |||||||
| 11563 | ######################################################################## | ||||||
| 11564 | # Handling of crypto tunnels. | ||||||
| 11565 | ######################################################################## | ||||||
| 11566 | |||||||
| 11567 | sub link_ipsec { | ||||||
| 11568 | 337 | 0 | 591 | for my $ipsec (values %ipsec) { | |||
| 11569 | |||||||
| 11570 | # Convert name of ISAKMP definition to object with ISAKMP definition. | ||||||
| 11571 | 20 20 | 19 34 | my ($type, $name) = @{ $ipsec->{key_exchange} }; | ||||
| 11572 | 20 | 33 | if ($type eq 'isakmp') { | ||||
| 11573 | 20 | 43 | my $isakmp = $isakmp{$name} | ||||
| 11574 | or err_msg "Can't resolve reference to $type:$name", | ||||||
| 11575 | " for $ipsec->{name}"; | ||||||
| 11576 | 20 | 50 | $ipsec->{key_exchange} = $isakmp; | ||||
| 11577 | } | ||||||
| 11578 | else { | ||||||
| 11579 | 0 | 0 | err_msg("Unknown key_exchange type '$type' for $ipsec->{name}"); | ||||
| 11580 | } | ||||||
| 11581 | } | ||||||
| 11582 | 337 | 313 | return; | ||||
| 11583 | } | ||||||
| 11584 | |||||||
| 11585 | sub link_crypto { | ||||||
| 11586 | 337 | 0 | 682 | for my $crypto (values %crypto) { | |||
| 11587 | 21 | 22 | my $name = $crypto->{name}; | ||||
| 11588 | |||||||
| 11589 | # Convert name of IPSec definition to object with IPSec definition. | ||||||
| 11590 | 21 21 | 18 32 | my ($type, $name2) = @{ $crypto->{type} }; | ||||
| 11591 | |||||||
| 11592 | 21 | 28 | if ($type eq 'ipsec') { | ||||
| 11593 | 21 | 45 | my $ipsec = $ipsec{$name2} | ||||
| 11594 | or err_msg "Can't resolve reference to $type:$name2", | ||||||
| 11595 | " for $name"; | ||||||
| 11596 | 21 | 36 | $crypto->{type} = $ipsec; | ||||
| 11597 | } | ||||||
| 11598 | else { | ||||||
| 11599 | 0 | 0 | err_msg("Unknown type '$type' for $name"); | ||||
| 11600 | } | ||||||
| 11601 | } | ||||||
| 11602 | 337 | 298 | return; | ||||
| 11603 | } | ||||||
| 11604 | |||||||
| 11605 | # Generate rules to permit crypto traffic between tunnel endpoints. | ||||||
| 11606 | sub gen_tunnel_rules { | ||||||
| 11607 | 27 | 0 | 25 | my ($intf1, $intf2, $ipsec) = @_; | |||
| 11608 | 27 | 23 | my $use_ah = $ipsec->{ah}; | ||||
| 11609 | 27 | 48 | my $use_esp = $ipsec->{esp_authentication} || $ipsec->{esp_encryption}; | ||||
| 11610 | 27 | 28 | my $nat_traversal = $ipsec->{key_exchange}->{nat_traversal}; | ||||
| 11611 | 27 | 24 | my @rules; | ||||
| 11612 | 27 | 42 | my $rule = { src => $intf1, dst => $intf2 }; | ||||
| 11613 | 27 | 76 | if (not $nat_traversal or $nat_traversal ne 'on') { | ||||
| 11614 | 27 | 33 | $use_ah | ||||
| 11615 | and push @rules, { %$rule, prt => $prt_ah }; | ||||||
| 11616 | 27 | 87 | $use_esp | ||||
| 11617 | and push @rules, { %$rule, prt => $prt_esp }; | ||||||
| 11618 | 27 | 71 | push @rules, | ||||
| 11619 | { | ||||||
| 11620 | %$rule, | ||||||
| 11621 | src_range => $prt_ike->{src_range}, | ||||||
| 11622 | prt => $prt_ike->{dst_range} | ||||||
| 11623 | }; | ||||||
| 11624 | } | ||||||
| 11625 | 27 | 45 | if ($nat_traversal) { | ||||
| 11626 | 15 | 32 | push @rules, | ||||
| 11627 | { | ||||||
| 11628 | %$rule, | ||||||
| 11629 | src_range => $prt_natt->{src_range}, | ||||||
| 11630 | prt => $prt_natt->{dst_range} | ||||||
| 11631 | }; | ||||||
| 11632 | } | ||||||
| 11633 | 27 | 62 | return \@rules; | ||||
| 11634 | } | ||||||
| 11635 | |||||||
| 11636 | # Link tunnel networks with tunnel hubs. | ||||||
| 11637 | # ToDo: Are tunnels between different private contexts allowed? | ||||||
| 11638 | sub link_tunnels { | ||||||
| 11639 | |||||||
| 11640 | 337 | 0 | 305 | my %hub_seen; | |||
| 11641 | |||||||
| 11642 | # Collect clear-text interfaces of all tunnels. | ||||||
| 11643 | my @real_interfaces; | ||||||
| 11644 | |||||||
| 11645 | 337 | 774 | for my $crypto (sort by_name values %crypto) { | ||||
| 11646 | 21 | 24 | my $name = $crypto->{name}; | ||||
| 11647 | 21 | 22 | my $private = $crypto->{private}; | ||||
| 11648 | 21 | 29 | my $real_hubs = delete $crypto2hubs{$name}; | ||||
| 11649 | 21 | 32 | my $real_spokes = delete $crypto2spokes{$name}; | ||||
| 11650 | 21 21 | 29 49 | $real_hubs = [ grep { !$_->{disabled} } @$real_hubs ]; | ||||
| 11651 | 21 25 | 24 44 | $real_spokes = [ grep { !$_->{disabled} } @$real_spokes ]; | ||||
| 11652 | 21 | 79 | $real_hubs and @$real_hubs | ||||
| 11653 | or warn_msg("No hubs have been defined for $name"); | ||||||
| 11654 | |||||||
| 11655 | 21 | 64 | $real_spokes and @$real_spokes | ||||
| 11656 | or warn_msg("No spokes have been defined for $name"); | ||||||
| 11657 | |||||||
| 11658 | 21 | 25 | my $isakmp = $crypto->{type}->{key_exchange}; | ||||
| 11659 | 21 | 34 | my $need_id = $isakmp->{authentication} eq 'rsasig'; | ||||
| 11660 | 21 | 24 | for my $real_hub (@$real_hubs) { | ||||
| 11661 | |||||||
| 11662 | # Substitute crypto name by crypto object. | ||||||
| 11663 | 21 21 | 13 32 | for my $crypto_name (@{ $real_hub->{hub} }) { | ||||
| 11664 | 27 | 63 | $crypto_name eq $name and $crypto_name = $crypto; | ||||
| 11665 | } | ||||||
| 11666 | |||||||
| 11667 | # Collect managed routers with crypto hub. | ||||||
| 11668 | # Note: Crypto routers are splitted internally into | ||||||
| 11669 | # two nodes. Typically we get get a node with only | ||||||
| 11670 | # a single crypto interface. | ||||||
| 11671 | 21 | 22 | my $router = $real_hub->{router}; | ||||
| 11672 | 21 | 32 | $router->{managed} or next; | ||||
| 11673 | |||||||
| 11674 | # Router of type {do_auth} can only check certificates, | ||||||
| 11675 | # not pre-shared keys. | ||||||
| 11676 | 21 | 59 | $router->{model}->{do_auth} and not $need_id and | ||||
| 11677 | err_msg("$router->{name} needs authentication=rsasig", | ||||||
| 11678 | " in $isakmp->{name}"); | ||||||
| 11679 | |||||||
| 11680 | # Take original router with cleartext interface(s). | ||||||
| 11681 | 21 | 32 | if (my $orig_router = $router->{orig_router}) { | ||||
| 11682 | 18 | 19 | $router = $orig_router; | ||||
| 11683 | } | ||||||
| 11684 | 21 | 77 | push @managed_crypto_hubs, $router if not $hub_seen{$router}++; | ||||
| 11685 | } | ||||||
| 11686 | 21 | 22 | push @real_interfaces, @$real_hubs; | ||||
| 11687 | |||||||
| 11688 | # Generate a single tunnel from each spoke to a single hub. | ||||||
| 11689 | # If there are multiple hubs, they are assumed to form | ||||||
| 11690 | # a high availability cluster. In this case a single tunnel is created | ||||||
| 11691 | # with all hubs as possible endpoints. Traffic between hubs is | ||||||
| 11692 | # prevented by automatically added pathrestrictions. | ||||||
| 11693 | 21 | 24 | for my $spoke_net (@$real_spokes) { | ||||
| 11694 | 25 | 90 | (my $net_name = $spoke_net->{name}) =~ s/network://; | ||||
| 11695 | 25 25 | 27 41 | push @{ $crypto->{tunnels} }, $spoke_net; | ||||
| 11696 | 25 | 30 | my $spoke = $spoke_net->{interfaces}->[0]; | ||||
| 11697 | 25 | 27 | $spoke->{crypto} = $crypto; | ||||
| 11698 | 25 | 21 | my $real_spoke = $spoke->{real_interface}; | ||||
| 11699 | 25 | 25 | $real_spoke->{spoke} = $crypto; | ||||
| 11700 | |||||||
| 11701 | # Each spoke gets a fresh hub interface. | ||||||
| 11702 | 25 | 20 | my @hubs; | ||||
| 11703 | 25 | 32 | for my $real_hub (@$real_hubs) { | ||||
| 11704 | 25 | 24 | my $router = $real_hub->{router}; | ||||
| 11705 | 25 | 40 | if (my $orig_router = $router->{orig_router}) { | ||||
| 11706 | 22 | 19 | $router = $orig_router; | ||||
| 11707 | } | ||||||
| 11708 | 25 | 25 | my $hardware = $real_hub->{hardware}; | ||||
| 11709 | 25 | 142 | (my $intf_name = $real_hub->{name}) =~ s/\..*$/.$net_name/; | ||||
| 11710 | 25 | 47 | my $hub = new( | ||||
| 11711 | 'Interface', | ||||||
| 11712 | name => $intf_name, | ||||||
| 11713 | ip => 'tunnel', | ||||||
| 11714 | crypto => $crypto, | ||||||
| 11715 | |||||||
| 11716 | # Attention: shared hardware between router and | ||||||
| 11717 | # orig_router. | ||||||
| 11718 | hardware => $hardware, | ||||||
| 11719 | is_hub => 1, | ||||||
| 11720 | real_interface => $real_hub, | ||||||
| 11721 | router => $router, | ||||||
| 11722 | network => $spoke_net | ||||||
| 11723 | ); | ||||||
| 11724 | 25 | 48 | $hub->{bind_nat} = $real_hub->{bind_nat} | ||||
| 11725 | if $real_hub->{bind_nat}; | ||||||
| 11726 | 25 25 | 21 30 | push @{ $router->{interfaces} }, $hub; | ||||
| 11727 | 25 25 | 27 25 | push @{ $hardware->{interfaces} }, $hub; | ||||
| 11728 | 25 25 | 18 24 | push @{ $spoke_net->{interfaces} }, $hub; | ||||
| 11729 | 25 25 | 20 38 | push @{ $hub->{peers} }, $spoke; | ||||
| 11730 | 25 25 | 18 37 | push @{ $spoke->{peers} }, $hub; | ||||
| 11731 | 25 | 29 | push @hubs, $hub; | ||||
| 11732 | |||||||
| 11733 | # We need hub also be available in orig_interfaces. | ||||||
| 11734 | 25 | 45 | if (my $aref = $router->{orig_interfaces}) { | ||||
| 11735 | 22 | 24 | push @$aref, $hub; | ||||
| 11736 | } | ||||||
| 11737 | |||||||
| 11738 | 25 | 108 | if ($real_spoke->{ip} =~ /^(?:negotiated|short|unnumbered)$/) { | ||||
| 11739 | 10 | 9 | my $model = $router->{model}; | ||||
| 11740 | 10 | 27 | if (not ( $model->{do_auth} or $model->{can_dyn_crypto})) { | ||||
| 11741 | 0 | 0 | err_msg "$router->{name} can't establish crypto", | ||||
| 11742 | " tunnel to $real_spoke->{name} with unknown IP"; | ||||||
| 11743 | } | ||||||
| 11744 | } | ||||||
| 11745 | |||||||
| 11746 | 25 | 35 | if ($private) { | ||||
| 11747 | 0 | 0 | my $s_p = $real_spoke->{private}; | ||||
| 11748 | 0 | 0 | my $h_p = $real_hub->{private}; | ||||
| 11749 | 0 | 0 | $s_p and $s_p eq $private | ||||
| 11750 | or $h_p and $h_p eq $private | ||||||
| 11751 | or err_msg | ||||||
| 11752 | "Tunnel $real_spoke->{name} to $real_hub->{name}", | ||||||
| 11753 | " of $private.private $name", | ||||||
| 11754 | " must reference at least one object", | ||||||
| 11755 | " out of $private.private"; | ||||||
| 11756 | } | ||||||
| 11757 | else { | ||||||
| 11758 | 25 | 39 | $real_spoke->{private} | ||||
| 11759 | and err_msg "Tunnel of public $name must not", | ||||||
| 11760 | " reference $real_spoke->{name} of", | ||||||
| 11761 | " $real_spoke->{private}.private"; | ||||||
| 11762 | 25 | 78 | $real_hub->{private} | ||||
| 11763 | and err_msg "Tunnel of public $name must not", | ||||||
| 11764 | " reference $real_hub->{name} of", | ||||||
| 11765 | " $real_hub->{private}.private"; | ||||||
| 11766 | } | ||||||
| 11767 | } | ||||||
| 11768 | |||||||
| 11769 | 25 | 32 | my $router = $spoke->{router}; | ||||
| 11770 | 25 | 16 | my @other; | ||||
| 11771 | my $has_id_hosts; | ||||||
| 11772 | 25 25 | 21 31 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 11773 | 56 | 50 | my $network = $interface->{network}; | ||||
| 11774 | 56 | 119 | if ($network->{has_id_hosts}) { | ||||
| 11775 | 12 | 11 | $has_id_hosts = $network; | ||||
| 11776 | } | ||||||
| 11777 | elsif ($interface->{ip} ne 'tunnel') | ||||||
| 11778 | { | ||||||
| 11779 | 19 | 23 | push @other, $interface; | ||||
| 11780 | } | ||||||
| 11781 | } | ||||||
| 11782 | 25 | 68 | if ($has_id_hosts and @other) { | ||||
| 11783 | 0 | 0 | err_msg "Must not use $has_id_hosts->{name} with ID hosts", | ||||
| 11784 | " together with networks having no ID host: ", | ||||||
| 11785 | 0 | 0 | join(',', map { $_->{name} } @other); | ||||
| 11786 | } | ||||||
| 11787 | 25 | 20 | push @real_interfaces, $real_spoke; | ||||
| 11788 | |||||||
| 11789 | 25 | 52 | if ($router->{managed} && $crypto->{detailed_crypto_acl}) { | ||||
| 11790 | 0 | 0 | err_msg( | ||||
| 11791 | "Attribute 'detailed_crypto_acl' is not", | ||||||
| 11792 | " allowed for managed spoke $router->{name}" | ||||||
| 11793 | ); | ||||||
| 11794 | } | ||||||
| 11795 | |||||||
| 11796 | # Automatically add pathrestriction between interfaces | ||||||
| 11797 | # of redundant hubs. | ||||||
| 11798 | 25 | 86 | if (@hubs > 1) { | ||||
| 11799 | 0 | 0 | my $name2 = "auto-restriction:$crypto->{name}"; | ||||
| 11800 | 0 | 0 | add_pathrestriction($name, \@hubs); | ||||
| 11801 | } | ||||||
| 11802 | } | ||||||
| 11803 | } | ||||||
| 11804 | |||||||
| 11805 | # Check for undefined crypto references. | ||||||
| 11806 | 337 | 550 | for my $crypto (keys %crypto2hubs) { | ||||
| 11807 | 0 0 | 0 0 | for my $interface (@{ $crypto2hubs{$crypto} }) { | ||||
| 11808 | 0 | 0 | err_msg("$interface->{name} references unknown $crypto"); | ||||
| 11809 | } | ||||||
| 11810 | } | ||||||
| 11811 | 337 | 521 | for my $crypto (keys %crypto2spokes) { | ||||
| 11812 | 0 0 | 0 0 | for my $network (@{ $crypto2spokes{$crypto} }) { | ||||
| 11813 | 0 | 0 | err_msg "$network->{interfaces}->[0]->{name}", | ||||
| 11814 | " references unknown $crypto"; | ||||||
| 11815 | } | ||||||
| 11816 | } | ||||||
| 11817 | 337 | 430 | return; | ||||
| 11818 | } | ||||||
| 11819 | |||||||
| 11820 | # Needed for crypto_rules, | ||||||
| 11821 | # for default route optimization, | ||||||
| 11822 | # while generating chains of iptables and | ||||||
| 11823 | # for local optimization. | ||||||
| 11824 | my $network_00 = new( | ||||||
| 11825 | 'Network', | ||||||
| 11826 | name => "network:0/0", | ||||||
| 11827 | ip => 0, | ||||||
| 11828 | mask => 0, | ||||||
| 11829 | is_aggregate => 1, | ||||||
| 11830 | is_supernet => 1 | ||||||
| 11831 | ); | ||||||
| 11832 | |||||||
| 11833 | sub crypto_behind { | ||||||
| 11834 | 28 | 0 | 26 | my ($interface, $managed) = @_; | |||
| 11835 | 28 | 35 | if ($managed) { | ||||
| 11836 | 4 | 3 | my $zone = $interface->{zone}; | ||||
| 11837 | 4 4 | 4 9 | 1 == @{ $zone->{interfaces} } | ||||
| 11838 | or err_msg "Exactly one security zone must be located behind", | ||||||
| 11839 | " managed crypto $interface->{name}"; | ||||||
| 11840 | 4 | 5 | my $zone_networks = $zone->{networks}; | ||||
| 11841 | 4 | 6 | return @$zone_networks; | ||||
| 11842 | } | ||||||
| 11843 | else { | ||||||
| 11844 | 24 | 23 | my $network = $interface->{network}; | ||||
| 11845 | 24 24 | 17 41 | 1 == @{ $network->{interfaces} } | ||||
| 11846 | or err_msg "Exactly one network must be located behind", | ||||||
| 11847 | " unmanaged crypto $interface->{name}"; | ||||||
| 11848 | 24 | 43 | return($network); | ||||
| 11849 | } | ||||||
| 11850 | } | ||||||
| 11851 | |||||||
| 11852 | # Valid group-policy attributes. | ||||||
| 11853 | # Hash describes usage: | ||||||
| 11854 | # - tg_general: attribute is only applicable to 'tunnel-group general-attributes' | ||||||
| 11855 | my %asa_vpn_attributes = ( | ||||||
| 11856 | |||||||
| 11857 | # group-policy attributes | ||||||
| 11858 | banner => {}, | ||||||
| 11859 | 'check-subject-name' => {}, | ||||||
| 11860 | 'dns-server' => {}, | ||||||
| 11861 | 'default-domain' => {}, | ||||||
| 11862 | 'split-dns' => {}, | ||||||
| 11863 | 'trust-point' => {}, | ||||||
| 11864 | 'wins-server' => {}, | ||||||
| 11865 | 'vpn-access-hours' => {}, | ||||||
| 11866 | 'vpn-idle-timeout' => {}, | ||||||
| 11867 | 'vpn-session-timeout' => {}, | ||||||
| 11868 | 'vpn-simultaneous-logins' => {}, | ||||||
| 11869 | vlan => {}, | ||||||
| 11870 | 'split-tunnel-policy' => {}, | ||||||
| 11871 | 'authentication-server-group' => { tg_general => 1 }, | ||||||
| 11872 | 'authorization-server-group' => { tg_general => 1 }, | ||||||
| 11873 | 'authorization-required' => { tg_general => 1 }, | ||||||
| 11874 | 'username-from-certificate' => { tg_general => 1 }, | ||||||
| 11875 | ); | ||||||
| 11876 | |||||||
| 11877 | sub verify_asa_vpn_attributes { | ||||||
| 11878 | 38 | 0 | 31 | my ($obj) = @_; | |||
| 11879 | 38 | 62 | my $attributes = $obj->{radius_attributes} or return; | ||||
| 11880 | 38 | 83 | for my $key (sort keys %$attributes) { | ||||
| 11881 | 32 | 43 | my $spec = $asa_vpn_attributes{$key}; | ||||
| 11882 | 32 | 42 | $spec or err_msg("Invalid radius_attribute '$key' at $obj->{name}"); | ||||
| 11883 | 32 | 74 | if ($key eq 'split-tunnel-policy') { | ||||
| 11884 | 3 | 6 | my $value = $attributes->{$key}; | ||||
| 11885 | 3 | 21 | $value =~ /^(?:tunnelall|tunnelspecified)$/ | ||||
| 11886 | or err_msg("Unsupported value in radius_attributes", | ||||||
| 11887 | " of $obj->{name}\n", | ||||||
| 11888 | " '$key = $value'"); | ||||||
| 11889 | } | ||||||
| 11890 | elsif ($key eq 'trust-point') { | ||||||
| 11891 | 14 | 24 | if (is_host($obj)) { | ||||
| 11892 | 3 | 9 | $obj->{range} or | ||||
| 11893 | err_msg("Must not use radius_attribute '$key'", | ||||||
| 11894 | " at $obj->{name}"); | ||||||
| 11895 | } | ||||||
| 11896 | elsif (is_network($obj)) { | ||||||
| 11897 | 3 6 3 | 3 13 5 | grep { $_->{ip} } @{ $obj->{hosts} } and | ||||
| 11898 | err_msg("Must not use radius_attribute '$key'", | ||||||
| 11899 | " at $obj->{name}"); | ||||||
| 11900 | } | ||||||
| 11901 | } | ||||||
| 11902 | } | ||||||
| 11903 | 38 | 43 | return; | ||||
| 11904 | } | ||||||
| 11905 | |||||||
| 11906 | # Host with ID that doesn't contain a '@' must use attribute 'verify-subject-name'. | ||||||
| 11907 | sub verify_subject_name { | ||||||
| 11908 | 18 | 0 | 16 | my ($host, $peers) = @_; | |||
| 11909 | 18 | 22 | my $id = $host->{id}; | ||||
| 11910 | 18 | 60 | return if $id =~ /@/; | ||||
| 11911 | my $has_attr = sub { | ||||||
| 11912 | 3 | 4 | my ($obj) = @_; | ||||
| 11913 | 3 | 5 | my $attributes = $obj->{radius_attributes}; | ||||
| 11914 | 3 | 24 | return ($attributes && $attributes->{'check-subject-name'}); | ||||
| 11915 | 3 | 10 | }; | ||||
| 11916 | 3 | 5 | return if $has_attr->($host); | ||||
| 11917 | 0 | 0 | return if $has_attr->($host->{network}); | ||||
| 11918 | 0 | 0 | my $missing; | ||||
| 11919 | 0 | 0 | for my $peer (@$peers) { | ||||
| 11920 | 0 | 0 | next if $has_attr->($peer->{router}); | ||||
| 11921 | 0 | 0 | $missing = 1; | ||||
| 11922 | } | ||||||
| 11923 | 0 | 0 | if ($missing) { | ||||
| 11924 | 0 | 0 | err_msg("Missing radius_attribute 'check-subject-name'\n", | ||||
| 11925 | " for $host->{name}"); | ||||||
| 11926 | } | ||||||
| 11927 | 0 | 0 | return; | ||||
| 11928 | } | ||||||
| 11929 | |||||||
| 11930 | sub verify_asa_trustpoint { | ||||||
| 11931 | 11 | 0 | 11 | my ($router, $crypto) = @_; | |||
| 11932 | 11 | 13 | my $isakmp = $crypto->{type}->{key_exchange}; | ||||
| 11933 | 11 | 19 | if ($isakmp->{authentication} eq 'rsasig') { | ||||
| 11934 | 9 | 18 | $isakmp->{trust_point} or | ||||
| 11935 | err_msg("Missing attribute 'trust_point' in", | ||||||
| 11936 | " $isakmp->{name} for $router->{name}"); | ||||||
| 11937 | } | ||||||
| 11938 | 11 | 22 | return; | ||||
| 11939 | } | ||||||
| 11940 | |||||||
| 11941 | sub expand_crypto { | ||||||
| 11942 | 239 | 0 | 309 | progress('Expanding crypto rules'); | |||
| 11943 | |||||||
| 11944 | 239 | 191 | my %id2interface; | ||||
| 11945 | |||||||
| 11946 | 239 | 423 | for my $crypto (values %crypto) { | ||||
| 11947 | 20 | 23 | my $name = $crypto->{name}; | ||||
| 11948 | 20 | 25 | my $isakmp = $crypto->{type}->{key_exchange}; | ||||
| 11949 | 20 | 26 | my $need_id = $isakmp->{authentication} eq 'rsasig'; | ||||
| 11950 | |||||||
| 11951 | # Do consistency checks and | ||||||
| 11952 | # add rules which allow encrypted traffic. | ||||||
| 11953 | 20 20 | 16 29 | for my $tunnel (@{ $crypto->{tunnels} }) { | ||||
| 11954 | 22 | 37 | next if $tunnel->{disabled}; | ||||
| 11955 | 22 22 | 15 28 | for my $tunnel_intf (@{ $tunnel->{interfaces} }) { | ||||
| 11956 | 44 | 107 | next if $tunnel_intf->{is_hub}; | ||||
| 11957 | 22 | 21 | my $router = $tunnel_intf->{router}; | ||||
| 11958 | 22 | 19 | my $peers = $tunnel_intf->{peers}; | ||||
| 11959 | 22 | 19 | my $managed = $router->{managed}; | ||||
| 11960 | 22 | 27 | my @encrypted; | ||||
| 11961 | my $has_id_hosts; | ||||||
| 11962 | 0 | 0 | my $has_other_network; | ||||
| 11963 | 0 | 0 | my @verify_radius_attributes; | ||||
| 11964 | 22 22 | 17 27 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 11965 | 50 | 125 | next if $interface eq $tunnel_intf; | ||||
| 11966 | 28 | 43 | if ($interface->{ip} eq 'tunnel') { | ||||
| 11967 | 0 | 0 | if ($managed && $router->{model}->{crypto} eq 'EZVPN') { | ||||
| 11968 | 0 | 0 | err_msg "Exactly 1 crypto tunnel expected", | ||||
| 11969 | " for $router->{name} with EZVPN"; | ||||||
| 11970 | } | ||||||
| 11971 | 0 | 0 | next; | ||||
| 11972 | } | ||||||
| 11973 | 28 | 44 | if ($interface->{spoke}) { | ||||
| 11974 | 0 | 0 | if (my $id = $interface->{id}) { | ||||
| 11975 | 0 | 0 | if (my $intf2 = $id2interface{$id}) { | ||||
| 11976 | 0 | 0 | err_msg "Same ID '$id' is used at", | ||||
| 11977 | " $interface->{name} and $intf2->{name}"; | ||||||
| 11978 | } | ||||||
| 11979 | 0 | 0 | $id2interface{$id} = $interface; | ||||
| 11980 | } | ||||||
| 11981 | 0 | 0 | next; | ||||
| 11982 | } | ||||||
| 11983 | 28 | 27 | my $network = $interface->{network}; | ||||
| 11984 | 28 | 36 | my @all_networks = crypto_behind($interface, $managed); | ||||
| 11985 | 28 | 35 | if ($network->{has_id_hosts}) { | ||||
| 11986 | 12 | 11 | $has_id_hosts = 1; | ||||
| 11987 | 12 | 18 | $managed | ||||
| 11988 | and err_msg | ||||||
| 11989 | "$network->{name} having ID hosts must not", | ||||||
| 11990 | " be located behind managed $router->{name}"; | ||||||
| 11991 | 12 | 12 | push @verify_radius_attributes, $network; | ||||
| 11992 | |||||||
| 11993 | # Must not have multiple networks. | ||||||
| 11994 | 12 | 20 | @all_networks > 1 and internal_err(); | ||||
| 11995 | |||||||
| 11996 | # Rules for single software clients are stored | ||||||
| 11997 | # individually at crypto hub interface. | ||||||
| 11998 | 12 12 | 12 14 | for my $host (@{ $network->{hosts} }) { | ||||
| 11999 | 18 | 19 | my $id = $host->{id}; | ||||
| 12000 | |||||||
| 12001 | # ID host has already been checked to have | ||||||
| 12002 | # exacly one subnet. | ||||||
| 12003 | 18 | 18 | my $subnet = $host->{subnets}->[0]; | ||||
| 12004 | 18 | 15 | push @verify_radius_attributes, $host; | ||||
| 12005 | 18 | 19 | for my $peer (@$peers) { | ||||
| 12006 | 18 | 14 | my $no_nat_set = $peer->{no_nat_set}; | ||||
| 12007 | 18 | 38 | if (my $other = $peer->{id_rules}->{$id}) { | ||||
| 12008 | 1 | 2 | my $src = $other->{src}; | ||||
| 12009 | 1 | 12 | err_msg("Duplicate ID-host $id from", | ||||
| 12010 | " $src->{network}->{name} and", | ||||||
| 12011 | " $subnet->{network}->{name}", | ||||||
| 12012 | " at $peer->{router}->{name}"); | ||||||
| 12013 | 1 | 3 | next; | ||||
| 12014 | } | ||||||
| 12015 | 17 | 105 | $peer->{id_rules}->{$id} = { | ||||
| 12016 | name => "$peer->{name}.$id", | ||||||
| 12017 | ip => 'tunnel', | ||||||
| 12018 | src => $subnet, | ||||||
| 12019 | no_nat_set => $no_nat_set, | ||||||
| 12020 | |||||||
| 12021 | # Needed during local_optimization. | ||||||
| 12022 | router => $peer->{router}, | ||||||
| 12023 | }; | ||||||
| 12024 | } | ||||||
| 12025 | } | ||||||
| 12026 | 12 | 21 | push @encrypted, $network; | ||||
| 12027 | } | ||||||
| 12028 | else { | ||||||
| 12029 | 16 | 16 | $has_other_network = 1; | ||||
| 12030 | 16 | 25 | push @encrypted, @all_networks; | ||||
| 12031 | } | ||||||
| 12032 | } | ||||||
| 12033 | $has_id_hosts | ||||||
| 12034 | 0 | 0 | and $has_other_network | ||||
| 12035 | and err_msg( | ||||||
| 12036 | "Must not use host with ID and network", | ||||||
| 12037 | " together at $tunnel_intf->{name}: ", | ||||||
| 12038 | 22 | 56 | join(', ', map { $_->{name} } @encrypted) | ||||
| 12039 | ); | ||||||
| 12040 | 0 | 0 | $has_id_hosts | ||||
| 12041 | or $has_other_network | ||||||
| 12042 | or err_msg( | ||||||
| 12043 | "Must use network or host with ID", | ||||||
| 12044 | " at $tunnel_intf->{name}: ", | ||||||
| 12045 | 22 | 56 | join(', ', map { $_->{name} } @encrypted) | ||||
| 12046 | ); | ||||||
| 12047 | |||||||
| 12048 | 22 | 22 | my $real_spoke = $tunnel_intf->{real_interface}; | ||||
| 12049 | 22 | 22 | for my $peer (@$peers) { | ||||
| 12050 | 22 | 28 | $peer->{peer_networks} = \@encrypted; | ||||
| 12051 | 22 | 20 | my $router = $peer->{router}; | ||||
| 12052 | 22 | 24 | my $do_auth = $router->{model}->{do_auth}; | ||||
| 12053 | 22 | 50 | my $unknown_ip = | ||||
| 12054 | $real_spoke->{ip} =~ | ||||||
| 12055 | /^(?:negotiated|short|unnumbered)$/; | ||||||
| 12056 | 22 | 48 | if ($tunnel_intf->{id}) { | ||||
| 12057 | 9 | 20 | $need_id or | ||||
| 12058 | err_msg("Invalid attribute 'id' at", | ||||||
| 12059 | " $tunnel_intf->{name}.\n", | ||||||
| 12060 | " Set authentication=rsasig at", | ||||||
| 12061 | " $isakmp->{name}"); | ||||||
| 12062 | } | ||||||
| 12063 | elsif ($encrypted[0]->{has_id_hosts}) { | ||||||
| 12064 | 10 | 25 | $do_auth | ||||
| 12065 | or err_msg("$router->{name} can't check IDs", | ||||||
| 12066 | " of $encrypted[0]->{name}"); | ||||||
| 12067 | } | ||||||
| 12068 | elsif ($need_id) { | ||||||
| 12069 | 1 | 5 | err_msg("$tunnel_intf->{name}", | ||||
| 12070 | " needs attribute 'id',", | ||||||
| 12071 | " because $isakmp->{name}", | ||||||
| 12072 | " has authentication=rsasig"); | ||||||
| 12073 | } | ||||||
| 12074 | } | ||||||
| 12075 | |||||||
| 12076 | 22 22 | 32 61 | if (grep({ $_->{router}->{model}->{crypto} eq 'ASA_VPN' } | ||||
| 12077 | @$peers)) | ||||||
| 12078 | { | ||||||
| 12079 | 11 | 20 | for my $obj (@verify_radius_attributes) { | ||||
| 12080 | 30 | 38 | verify_asa_vpn_attributes($obj); | ||||
| 12081 | 30 | 34 | if (is_host($obj)) { | ||||
| 12082 | 18 | 21 | verify_subject_name($obj, $peers); | ||||
| 12083 | } | ||||||
| 12084 | } | ||||||
| 12085 | } | ||||||
| 12086 | |||||||
| 12087 | 22 | 52 | if ($managed && $router->{model}->{crypto} eq 'ASA') { | ||||
| 12088 | 0 | 0 | verify_asa_trustpoint($router, $crypto); | ||||
| 12089 | } | ||||||
| 12090 | |||||||
| 12091 | # Add rules to permit crypto traffic between | ||||||
| 12092 | # tunnel endpoints. | ||||||
| 12093 | # If one tunnel endpoint has no known IP address, | ||||||
| 12094 | # some rules have to be added manually. | ||||||
| 12095 | 22 | 105 | if ( $real_spoke | ||||
| 12096 | and $real_spoke->{ip} !~ /^(?:short|unnumbered)$/) | ||||||
| 12097 | { | ||||||
| 12098 | 15 15 | 13 18 | for my $hub (@{ $tunnel_intf->{peers} }) { | ||||
| 12099 | 15 | 15 | my $real_hub = $hub->{real_interface}; | ||||
| 12100 | 15 | 30 | for my $pair ( | ||||
| 12101 | [ $real_spoke, $real_hub ], | ||||||
| 12102 | [ $real_hub, $real_spoke ] | ||||||
| 12103 | ) | ||||||
| 12104 | { | ||||||
| 12105 | 30 | 27 | my ($intf1, $intf2) = @$pair; | ||||
| 12106 | |||||||
| 12107 | # Don't generate incoming ACL from unknown | ||||||
| 12108 | # address. | ||||||
| 12109 | 30 | 50 | next if $intf1->{ip} eq 'negotiated'; | ||||
| 12110 | 27 | 43 | my $rules_ref = | ||||
| 12111 | gen_tunnel_rules($intf1, $intf2, | ||||||
| 12112 | $crypto->{type}); | ||||||
| 12113 | 27 27 | 20 42 | push @{ $expanded_rules{permit} }, @$rules_ref; | ||||
| 12114 | 27 | 36 | add_rules $rules_ref; | ||||
| 12115 | } | ||||||
| 12116 | } | ||||||
| 12117 | } | ||||||
| 12118 | } | ||||||
| 12119 | } | ||||||
| 12120 | } | ||||||
| 12121 | |||||||
| 12122 | # Check for duplicate IDs of different hosts | ||||||
| 12123 | # coming into different hardware at current device. | ||||||
| 12124 | # ASA_VPN can't distinguish different hosts with same ID | ||||||
| 12125 | # coming into different hardware interfaces. | ||||||
| 12126 | 239 | 332 | for my $router (@managed_crypto_hubs) { | ||||
| 12127 | 16 | 18 | my $model = $router->{model}; | ||||
| 12128 | 16 | 30 | my $crypto = $model->{crypto} or next; | ||||
| 12129 | 16 | 35 | $crypto eq 'ASA_VPN' or next; | ||||
| 12130 | 19 | 27 | my @id_rules_interfaces = | ||||
| 12131 | 8 8 | 8 11 | grep { $_->{id_rules} } @{ $router->{interfaces} }; | ||||
| 12132 | 8 | 19 | @id_rules_interfaces >= 2 or next; | ||||
| 12133 | 3 | 3 | my %id2src; | ||||
| 12134 | 3 | 6 | for my $interface (@id_rules_interfaces) { | ||||
| 12135 | 6 | 7 | my $hash = $interface->{id_rules}; | ||||
| 12136 | 6 | 10 | for my $id (keys %$hash) { | ||||
| 12137 | 10 | 13 | my $src1 = $hash->{$id}->{src}; | ||||
| 12138 | 10 | 16 | if (my $src2 = $id2src{$id}) { | ||||
| 12139 | 1 | 6 | err_msg("Duplicate ID-host $id from", | ||||
| 12140 | " $src1->{network}->{name} and", | ||||||
| 12141 | " $src2->{network}->{name}", | ||||||
| 12142 | " at $router->{name}"); | ||||||
| 12143 | } | ||||||
| 12144 | else { | ||||||
| 12145 | 9 | 21 | $id2src{$id} = $src1; | ||||
| 12146 | } | ||||||
| 12147 | } | ||||||
| 12148 | } | ||||||
| 12149 | } | ||||||
| 12150 | |||||||
| 12151 | 239 | 619 | for my $router (@managed_crypto_hubs) { | ||||
| 12152 | 16 | 20 | my $crypto_type = $router->{model}->{crypto}; | ||||
| 12153 | 16 | 31 | if ($crypto_type eq 'ASA_VPN') { | ||||
| 12154 | 8 | 12 | verify_asa_vpn_attributes($router); | ||||
| 12155 | |||||||
| 12156 | # Move 'trust-point' from radius_attributes to router attribute. | ||||||
| 12157 | 8 | 19 | my $trust_point = | ||||
| 12158 | delete $router->{radius_attributes}->{'trust-point'} | ||||||
| 12159 | or err_msg("Missing 'trust-point' in radius_attributes", | ||||||
| 12160 | " of $router->{name}"); | ||||||
| 12161 | 8 | 18 | $router->{trust_point} = $trust_point; | ||||
| 12162 | } | ||||||
| 12163 | elsif($crypto_type eq 'ASA') { | ||||||
| 12164 | 8 8 | 7 9 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 12165 | 19 | 34 | my $crypto = $interface->{crypto} or next; | ||||
| 12166 | 11 | 15 | verify_asa_trustpoint($router, $crypto); | ||||
| 12167 | } | ||||||
| 12168 | } | ||||||
| 12169 | } | ||||||
| 12170 | |||||||
| 12171 | # Hash only needed during expand_group and expand_rules. | ||||||
| 12172 | 239 | 280 | %auto_interfaces = (); | ||||
| 12173 | 239 | 244 | return; | ||||
| 12174 | } | ||||||
| 12175 | |||||||
| 12176 | # Hash for converting a reference of an object back to this object. | ||||||
| 12177 | my %ref2obj; | ||||||
| 12178 | |||||||
| 12179 | sub setup_ref2obj { | ||||||
| 12180 | 226 | 0 | 272 | for my $network (@networks) { | |||
| 12181 | 938 | 1275 | $ref2obj{$network} = $network; | ||||
| 12182 | 938 938 938 | 706 1082 1127 | for my $obj (@{ $network->{subnets} }, @{ $network->{interfaces} }) { | ||||
| 12183 | 1332 | 2536 | $ref2obj{$obj} = $obj; | ||||
| 12184 | } | ||||||
| 12185 | } | ||||||
| 12186 | 226 | 220 | return; | ||||
| 12187 | } | ||||||
| 12188 | |||||||
| 12189 | ############################################################################## | ||||||
| 12190 | # Check if high-level and low-level semantics of rules with an supernet | ||||||
| 12191 | # as source or destination are equivalent. | ||||||
| 12192 | # | ||||||
| 12193 | # I. Typically, we only use incoming ACLs. | ||||||
| 12194 | # (A) rule "permit any:X dst" | ||||||
| 12195 | # high-level: any:X in zone X get access to dst | ||||||
| 12196 | # low-level: like above, but additionally, the networks matching any:X | ||||||
| 12197 | # in all zones on the path from zone X to dst get access to dst. | ||||||
| 12198 | # (B) rule permit src any:X | ||||||
| 12199 | # high-level: src gets access to any:X in zone X | ||||||
| 12200 | # low-level: like above, but additionally, src gets access to all networks | ||||||
| 12201 | # matching any:X in all zones located directly behind | ||||||
| 12202 | # all routers on the path from src to zone X. | ||||||
| 12203 | # | ||||||
| 12204 | # II. Alternatively, we have a single interface Y (with attached zone Y) | ||||||
| 12205 | # without ACL and all other interfaces having incoming and outgoing ACLs. | ||||||
| 12206 | # (A) rule "permit any:X dst" | ||||||
| 12207 | # a) dst behind Y: filtering occurs at incoming ACL of X, good. | ||||||
| 12208 | # b) dst not behind Y: | ||||||
| 12209 | # 1. zone X == zone Y: filtering occurs at outgoing ACL, good. | ||||||
| 12210 | # 2. zone X != zone Y: outgoing ACL would accidently | ||||||
| 12211 | # permit any:Y->dst, bad. | ||||||
| 12212 | # Additional rule required: "permit any:Y->dst" | ||||||
| 12213 | # (B) rule "permit src any:X" | ||||||
| 12214 | # a) src behind Y: filtering occurs at ougoing ACL, good | ||||||
| 12215 | # b) src not behind Y: | ||||||
| 12216 | # 1. zone X == zone Y: filtering occurs at incoming ACL at src and | ||||||
| 12217 | # at outgoing ACls of other non-zone X interfaces, good. | ||||||
| 12218 | # 2. zone X != zone Y: incoming ACL at src would permit | ||||||
| 12219 | # src->any:Y, bad | ||||||
| 12220 | # Additional rule required: "permit src->any:Y". | ||||||
| 12221 | ############################################################################## | ||||||
| 12222 | |||||||
| 12223 | my %supernet_rule_tree; | ||||||
| 12224 | |||||||
| 12225 | # Collect rules with destination aggregate/supernet | ||||||
| 12226 | # - that are filtered at the same router which is attached | ||||||
| 12227 | # to the destination zone | ||||||
| 12228 | # - the destination router is entered by the same interface | ||||||
| 12229 | # - src, src_range, prt, stateless are identical | ||||||
| 12230 | # - dst is supernet or aggregate with identical ip/mask | ||||||
| 12231 | sub collect_supernet_dst_rules { | ||||||
| 12232 | |||||||
| 12233 | # Function is called from path_walk. | ||||||
| 12234 | 86 | 0 | 1138 | my ($rule, $in_intf, $out_intf) = @_; | |||
| 12235 | |||||||
| 12236 | # Source is interface of current router. | ||||||
| 12237 | 86 | 123 | return if !$in_intf; | ||||
| 12238 | |||||||
| 12239 | # Ignore semi_managed router. | ||||||
| 12240 | 78 | 77 | my $router = $in_intf->{router}; | ||||
| 12241 | 78 | 129 | return if !$router->{managed}; | ||||
| 12242 | |||||||
| 12243 | 75 | 70 | my $dst = $rule->{dst}; | ||||
| 12244 | 75 | 65 | my $zone = $dst->{zone}; | ||||
| 12245 | 75 | 171 | return if $out_intf->{zone} ne $zone; | ||||
| 12246 | |||||||
| 12247 | # Get NAT address of supernet. | ||||||
| 12248 | 54 | 88 | if (!$dst->{is_aggregate}) { | ||||
| 12249 | 21 | 16 | my $no_nat_set = $in_intf->{no_nat_set}; | ||||
| 12250 | 21 | 31 | my $dst = get_nat_network($dst, $no_nat_set); | ||||
| 12251 | 21 | 51 | return if $dst->{hidden}; | ||||
| 12252 | } | ||||||
| 12253 | |||||||
| 12254 | 54 54 | 44 123 | my $ipmask = join('/', @{$dst}{qw(ip mask)}); | ||||
| 12255 | 54 | 73 | my ($stateless, $src, $src_range, $prt) = | ||||
| 12256 | 54 | 57 | @{$rule}{qw(stateless src src_range prt)}; | ||||
| 12257 | 54 | 149 | $stateless ||= ''; | ||||
| 12258 | 54 | 124 | $src_range ||= $prt_ip; | ||||
| 12259 | 54 | 242 | $supernet_rule_tree{$stateless}->{$src}->{$src_range}->{$prt} | ||||
| 12260 | ->{$in_intf}->{$ipmask}->{$zone} = $rule; | ||||||
| 12261 | 54 | 98 | return; | ||||
| 12262 | } | ||||||
| 12263 | |||||||
| 12264 | sub find_supernet { | ||||||
| 12265 | 3 | 0 | 3 | my ($net1, $net2) = @_; | |||
| 12266 | |||||||
| 12267 | # Start with $net1 being the smaller network. | ||||||
| 12268 | 3 | 8 | ($net1, $net2) = ($net2, $net1) if $net1->{mask} < $net2->{mask}; | ||||
| 12269 | 3 | 3 | while (1) { | ||||
| 12270 | 4 | 8 | while ($net1->{mask} > $net2->{mask}) { | ||||
| 12271 | 2 | 7 | $net1 = $net1->{up} or return; | ||||
| 12272 | } | ||||||
| 12273 | 3 | 10 | return $net1 if $net1 eq $net2; | ||||
| 12274 | 2 | 7 | $net2 = $net2->{up} or return; | ||||
| 12275 | } | ||||||
| 12276 | 0 | 0 | return; # unused; only for perlcritic | ||||
| 12277 | } | ||||||
| 12278 | |||||||
| 12279 | # Find networks in zone with address | ||||||
| 12280 | # - equal to ip/mask or | ||||||
| 12281 | # - subnet of ip/mask | ||||||
| 12282 | # Leave out small networks which are subnet of a matching network. | ||||||
| 12283 | # Result: | ||||||
| 12284 | # 0: no network found | ||||||
| 12285 | # network: | ||||||
| 12286 | # a) exactly one network matches, i.e. is equal or subnet. | ||||||
| 12287 | # b) a supernet which encloses multiple matching networks | ||||||
| 12288 | # String: More than one network found and no supernet exists. | ||||||
| 12289 | # String has the name of first two networks. | ||||||
| 12290 | sub find_zone_network { | ||||||
| 12291 | 59 | 0 | 59 | my ($interface, $zone, $other) = @_; | |||
| 12292 | 59 | 55 | my $no_nat_set = $interface->{no_nat_set}; | ||||
| 12293 | 59 | 77 | my $nat_other = get_nat_network($other, $no_nat_set); | ||||
| 12294 | 59 | 101 | return 0 if $nat_other->{hidden}; | ||||
| 12295 | 59 59 | 50 85 | my ($ip, $mask) = @{$nat_other}{qw(ip mask)}; | ||||
| 12296 | 59 | 95 | my $key = "$ip/$mask"; | ||||
| 12297 | 59 | 115 | if (my $aggregate = $zone->{ipmask2aggregate}->{$key}) { | ||||
| 12298 | 7 | 13 | return $aggregate; | ||||
| 12299 | } | ||||||
| 12300 | 52 | 109 | if (my $result = $zone->{ipmask2net}->{$key}) { | ||||
| 12301 | 0 | 0 | return $result; | ||||
| 12302 | } | ||||||
| 12303 | |||||||
| 12304 | # Real networks in zone without aggregates and without subnets. | ||||||
| 12305 | 52 | 44 | my $networks = $zone->{networks}; | ||||
| 12306 | 52 | 43 | my $result = 0; | ||||
| 12307 | 52 | 75 | for my $network (@$networks) { | ||||
| 12308 | 57 | 65 | my $nat_network = get_nat_network($network, $no_nat_set); | ||||
| 12309 | 57 | 91 | next if $nat_network->{hidden}; | ||||
| 12310 | 57 57 | 50 71 | my ($i, $m) = @{$nat_network}{qw(ip mask)}; | ||||
| 12311 | 57 | 138 | next if $i =~ /^(?:unnumbered|tunnel)$/; | ||||
| 12312 | |||||||
| 12313 | 57 | 216 | if ( $m >= $mask && match_ip($i, $ip, $mask) | ||||
| 12314 | || $m < $mask && match_ip($ip, $i, $m)) | ||||||
| 12315 | { | ||||||
| 12316 | |||||||
| 12317 | # Found first matching network. | ||||||
| 12318 | 24 | 35 | if (!$result) { | ||||
| 12319 | 21 | 16 | $result = $network; | ||||
| 12320 | 21 | 37 | next; | ||||
| 12321 | } | ||||||
| 12322 | |||||||
| 12323 | # Search a common supernet of two networks | ||||||
| 12324 | 3 | 9 | if (my $super = find_supernet($result, $network)) { | ||||
| 12325 | 1 | 2 | $result = $super; | ||||
| 12326 | } | ||||||
| 12327 | else { | ||||||
| 12328 | 2 | 5 | $result = "$result->{name}, $network->{name}"; | ||||
| 12329 | 2 | 4 | last; | ||||
| 12330 | } | ||||||
| 12331 | } | ||||||
| 12332 | } | ||||||
| 12333 | # debug "zone_network:", ref($result) ? $result->{name} : $result; | ||||||
| 12334 | 52 | 116 | return ($zone->{ipmask2net}->{$key} = $result); | ||||
| 12335 | } | ||||||
| 12336 | |||||||
| 12337 | # Find all networks in zone, which match network from other zone. | ||||||
| 12338 | # Result: | ||||||
| 12339 | # undef: No network of zone matches $other. | ||||||
| 12340 | # [] : Multiple networks match, but no supernet exists. | ||||||
| 12341 | # [N, ..]: Array reference to networks which match $other (ascending order). | ||||||
| 12342 | sub find_matching_supernet { | ||||||
| 12343 | 59 | 0 | 62 | my ($interface, $zone, $other) = @_; | |||
| 12344 | 59 | 79 | my $net_or_count = find_zone_network($interface, $zone, $other); | ||||
| 12345 | |||||||
| 12346 | # No network or aggregate matches. | ||||||
| 12347 | # $other wont match in current zone. | ||||||
| 12348 | 59 | 97 | if (!$net_or_count) { | ||||
| 12349 | 31 | 38 | return; | ||||
| 12350 | } | ||||||
| 12351 | |||||||
| 12352 | # More than one network matches and no supernet exists. | ||||||
| 12353 | # Return names of that networks. | ||||||
| 12354 | 28 | 44 | if (!ref($net_or_count)) { | ||||
| 12355 | 2 | 4 | return $net_or_count; | ||||
| 12356 | } | ||||||
| 12357 | |||||||
| 12358 | # Exactly one network or aggregate matches or supernet exists. | ||||||
| 12359 | 26 | 28 | my @result; | ||||
| 12360 | |||||||
| 12361 | # Add enclosing supernets. | ||||||
| 12362 | 26 | 30 | my $up = $net_or_count; | ||||
| 12363 | 26 | 42 | while ($up) { | ||||
| 12364 | 28 | 30 | push @result, $up; | ||||
| 12365 | 28 | 53 | $up = $up->{up}; | ||||
| 12366 | } | ||||||
| 12367 | # debug "matching:", join(',', map { $_->{name} } @result); | ||||||
| 12368 | 26 | 35 | return \@result; | ||||
| 12369 | } | ||||||
| 12370 | |||||||
| 12371 | # Prevent multiple error messages about missing supernet rules; | ||||||
| 12372 | my %missing_supernet; | ||||||
| 12373 | |||||||
| 12374 | # $rule: the rule to be checked | ||||||
| 12375 | # $where: has value 'src' or 'dst' | ||||||
| 12376 | # $interface: interface, where traffic reaches the device, | ||||||
| 12377 | # this is used to determine no_nat_set | ||||||
| 12378 | # $zone: The zone to be checked. | ||||||
| 12379 | # If $where is 'src', then $zone is attached to $interface | ||||||
| 12380 | # If $where is 'dst', then $zone is at other side of device. | ||||||
| 12381 | # $reversed: (optional) the check is for reversed rule at stateless device | ||||||
| 12382 | sub check_supernet_in_zone { | ||||||
| 12383 | 68 | 0 | 109 | my ($rule, $where, $interface, $zone, $reversed) = @_; | |||
| 12384 | |||||||
| 12385 | 68 | 126 | my ($stateless, $deny, $src, $dst, $src_range, $prt) = | ||||
| 12386 | 68 | 61 | @{$rule}{qw(stateless deny src dst src_range prt)}; | ||||
| 12387 | 68 | 181 | $stateless ||= ''; | ||||
| 12388 | 68 | 163 | $src_range ||= $prt_ip; | ||||
| 12389 | 68 | 96 | my $other = $where eq 'src' ? $src : $dst; | ||||
| 12390 | |||||||
| 12391 | # Fast check for access to aggregate/supernet with identical | ||||||
| 12392 | # ip/mask to $zone. | ||||||
| 12393 | 68 | 102 | if ($where eq 'dst') { | ||||
| 12394 | |||||||
| 12395 | # Get NAT address of supernet. | ||||||
| 12396 | 49 | 79 | if (!$dst->{is_aggregate}) { | ||||
| 12397 | 16 | 17 | my $no_nat_set = $interface->{no_nat_set}; | ||||
| 12398 | 16 | 19 | $dst = get_nat_network($dst, $no_nat_set); | ||||
| 12399 | 16 | 30 | return if $dst->{hidden}; | ||||
| 12400 | } | ||||||
| 12401 | 49 49 | 42 85 | my $ipmask = join('/', @{$dst}{qw(ip mask)}); | ||||
| 12402 | 49 | 233 | return if $supernet_rule_tree{$stateless}->{$src}->{$src_range} | ||||
| 12403 | ->{$prt}->{$interface}->{$ipmask}->{$zone}; | ||||||
| 12404 | } | ||||||
| 12405 | |||||||
| 12406 | 59 | 88 | my $networks = find_matching_supernet($interface, $zone, $other); | ||||
| 12407 | 59 | 126 | return if not $networks; | ||||
| 12408 | 28 | 23 | my $extra; | ||||
| 12409 | 28 | 51 | if (!ref($networks)) { | ||||
| 12410 | 2 | 3 | $extra = "No supernet available for $networks"; | ||||
| 12411 | } | ||||||
| 12412 | else { | ||||||
| 12413 | |||||||
| 12414 | # $networks holds matching network and all its supernets. | ||||||
| 12415 | # Find first matching rule. | ||||||
| 12416 | 26 | 73 | $deny ||= ''; | ||||
| 12417 | 26 | 32 | for my $network (@$networks) { | ||||
| 12418 | 28 | 43 | ($where eq 'src' ? $src : $dst) = $network; | ||||
| 12419 | 28 | 109 | if ($rule_tree{$stateless}->{$deny}->{$src_range}->{$src} | ||||
| 12420 | ->{$dst}->{$prt}) | ||||||
| 12421 | { | ||||||
| 12422 | 17 | 41 | return; | ||||
| 12423 | } | ||||||
| 12424 | } | ||||||
| 12425 | 9 9 | 11 25 | $extra = "Tried " . join(', ', map { $_->{name} } @$networks); | ||||
| 12426 | } | ||||||
| 12427 | |||||||
| 12428 | 11 | 14 | my $service = $rule->{rule}->{service}; | ||||
| 12429 | 11 | 34 | return if $missing_supernet{$interface}->{$service}; | ||||
| 12430 | 8 | 17 | $missing_supernet{$interface}->{$service} = 1; | ||||
| 12431 | |||||||
| 12432 | 8 | 10 | $rule = print_rule $rule; | ||||
| 12433 | 8 | 14 | $reversed = $reversed ? 'reversed ' : ''; | ||||
| 12434 | 8 | 18 | my $print = | ||||
| 12435 | $config{check_supernet_rules} eq 'warn' ? \&warn_msg : \&err_msg; | ||||||
| 12436 | 8 | 51 | $print->( | ||||
| 12437 | "Missing rule for ${reversed}supernet rule.\n", | ||||||
| 12438 | " $rule\n", | ||||||
| 12439 | " can't be effective at $interface->{name}.\n", | ||||||
| 12440 | " $extra as $where." | ||||||
| 12441 | ); | ||||||
| 12442 | 8 | 25 | return; | ||||
| 12443 | } | ||||||
| 12444 | |||||||
| 12445 | # If such rule is defined | ||||||
| 12446 | # permit supernet1 dst | ||||||
| 12447 | # | ||||||
| 12448 | # and topology is like this: | ||||||
| 12449 | # | ||||||
| 12450 | # supernet1-R1-zone2-R2-zone3-R3-dst | ||||||
| 12451 | # zone4-/ | ||||||
| 12452 | # | ||||||
| 12453 | # additional rules need to be defined as well: | ||||||
| 12454 | # permit supernet(zone2) dst | ||||||
| 12455 | # permit supernet(zone3) dst | ||||||
| 12456 | # | ||||||
| 12457 | # If R2 is stateless, we need one more rule to be defined: | ||||||
| 12458 | # permit supernet(zone4) dst | ||||||
| 12459 | # This is so, because at R2 we would get an automatically generated | ||||||
| 12460 | # reverse rule | ||||||
| 12461 | # permit dst supernet1 | ||||||
| 12462 | # which would accidentally permit traffic to supernet:[zone4] as well. | ||||||
| 12463 | sub check_supernet_src_rule { | ||||||
| 12464 | |||||||
| 12465 | # Function is called from path_walk. | ||||||
| 12466 | 91 | 0 | 95 | my ($rule, $in_intf, $out_intf) = @_; | |||
| 12467 | |||||||
| 12468 | # Destination is interface of current router and therefore there is | ||||||
| 12469 | # nothing to be checked. | ||||||
| 12470 | 91 | 134 | return unless $out_intf; | ||||
| 12471 | |||||||
| 12472 | # Ignore semi_managed router. | ||||||
| 12473 | 78 | 83 | my $router = $in_intf->{router}; | ||||
| 12474 | 78 | 118 | return if not $router->{managed}; | ||||
| 12475 | |||||||
| 12476 | 74 | 68 | my $out_zone = $out_intf->{zone}; | ||||
| 12477 | 74 | 69 | my $dst = $rule->{dst}; | ||||
| 12478 | 74 | 154 | my $dst_zone = get_zone($dst); | ||||
| 12479 | 74 | 172 | if ($dst->{is_supernet} && $out_zone eq $dst_zone) { | ||||
| 12480 | |||||||
| 12481 | # Both src and dst are supernets and are directly connected | ||||||
| 12482 | # at current router. Hence there can't be any missing rules. | ||||||
| 12483 | # Note: Additional checks will be done for this situation at | ||||||
| 12484 | # check_supernet_dst_rule | ||||||
| 12485 | 8 | 13 | return; | ||||
| 12486 | } | ||||||
| 12487 | 66 | 56 | my $in_zone = $in_intf->{zone}; | ||||
| 12488 | |||||||
| 12489 | # Check case II, outgoing ACL, (A) | ||||||
| 12490 | 66 | 51 | my $no_acl_intf; | ||||
| 12491 | 66 | 115 | if ($no_acl_intf = $router->{no_in_acl}) { | ||||
| 12492 | 2 | 1 | my $no_acl_zone = $no_acl_intf->{zone}; | ||||
| 12493 | |||||||
| 12494 | # a) dst behind Y | ||||||
| 12495 | 2 | 8 | if ($no_acl_zone eq $dst_zone) { | ||||
| 12496 | } | ||||||
| 12497 | |||||||
| 12498 | # b), 1. zone X == zone Y | ||||||
| 12499 | elsif ($in_zone eq $no_acl_zone) { | ||||||
| 12500 | } | ||||||
| 12501 | |||||||
| 12502 | elsif ($no_acl_intf->{main_interface}) { | ||||||
| 12503 | } | ||||||
| 12504 | |||||||
| 12505 | # b), 2. zone X != zone Y | ||||||
| 12506 | else { | ||||||
| 12507 | 0 | 0 | check_supernet_in_zone($rule, 'src', $no_acl_intf, $no_acl_zone); | ||||
| 12508 | } | ||||||
| 12509 | } | ||||||
| 12510 | 66 | 61 | my $src = $rule->{src}; | ||||
| 12511 | 66 | 62 | my $src_zone = $src->{zone}; | ||||
| 12512 | |||||||
| 12513 | # Check if reverse rule would be created and would need additional rules. | ||||||
| 12514 | 66 | 137 | if ($router->{model}->{stateless} && !$rule->{oneway}) | ||||
| 12515 | |||||||
| 12516 | { | ||||||
| 12517 | 4 | 6 | my $proto = $rule->{prt}->{proto}; | ||||
| 12518 | |||||||
| 12519 | # Reverse rule wouldn't allow too much traffic, if a non | ||||||
| 12520 | # secondary stateful device filters between current device and dst. | ||||||
| 12521 | # This is true if $out_zone and $dst_zone have different | ||||||
| 12522 | # {stateful_mark}. | ||||||
| 12523 | # If dst is managed interface, {stateful_mark} is undef | ||||||
| 12524 | # - if device is secondary managed, take mark of attached network | ||||||
| 12525 | # - else take value -1, different from all marks. | ||||||
| 12526 | # $src is supernet (not an interface) by definition | ||||||
| 12527 | # and hence $m1 is well defined. | ||||||
| 12528 | 4 | 4 | my $m1 = $out_zone->{stateful_mark}; | ||||
| 12529 | 4 | 3 | my $m2 = $dst_zone->{stateful_mark}; | ||||
| 12530 | 4 | 7 | if (!$m2) { | ||||
| 12531 | 0 | 0 | my $managed = $dst->{router}->{managed}; | ||||
| 12532 | 0 | 0 | $m2 = | ||||
| 12533 | $managed =~ /^(?:secondary|local.*)$/ | ||||||
| 12534 | ? $dst->{network}->{zone}->{stateful_mark} | ||||||
| 12535 | : -1; | ||||||
| 12536 | } | ||||||
| 12537 | 4 | 24 | if (($proto eq 'tcp' || $proto eq 'udp' || $proto eq 'ip') | ||||
| 12538 | && $m1 == $m2) | ||||||
| 12539 | { | ||||||
| 12540 | |||||||
| 12541 | # Check case II, outgoing ACL, (B), interface Y without ACL. | ||||||
| 12542 | 2 | 3 | if (my $no_acl_intf = $router->{no_in_acl}) { | ||||
| 12543 | 0 | 0 | my $no_acl_zone = $no_acl_intf->{zone}; | ||||
| 12544 | |||||||
| 12545 | # a) dst behind Y | ||||||
| 12546 | 0 | 0 | if ($no_acl_zone eq $dst_zone) { | ||||
| 12547 | } | ||||||
| 12548 | |||||||
| 12549 | # b) dst not behind Y | ||||||
| 12550 | # zone X == zone Y | ||||||
| 12551 | elsif ($no_acl_zone eq $src_zone) { | ||||||
| 12552 | } | ||||||
| 12553 | |||||||
| 12554 | elsif ($no_acl_intf->{main_interface}) { | ||||||
| 12555 | } | ||||||
| 12556 | |||||||
| 12557 | # zone X != zone Y | ||||||
| 12558 | else { | ||||||
| 12559 | 0 | 0 | check_supernet_in_zone($rule, 'src', $no_acl_intf, | ||||
| 12560 | $no_acl_zone, 1); | ||||||
| 12561 | } | ||||||
| 12562 | } | ||||||
| 12563 | |||||||
| 12564 | # Standard incoming ACL at all interfaces. | ||||||
| 12565 | else { | ||||||
| 12566 | |||||||
| 12567 | # Find security zones at all interfaces except the in_intf. | ||||||
| 12568 | 2 2 | 3 2 | for my $intf (@{ $router->{interfaces} }) { | ||||
| 12569 | 4 | 16 | next if $intf eq $in_intf; | ||||
| 12570 | 2 | 5 | next if $intf->{loopback} && ! $intf->{vip}; | ||||
| 12571 | |||||||
| 12572 | # Nothing to be checked for an interface directly | ||||||
| 12573 | # connected to src or dst. | ||||||
| 12574 | 2 | 1 | my $zone = $intf->{zone}; | ||||
| 12575 | 2 | 5 | next if $zone eq $src_zone; | ||||
| 12576 | 2 | 5 | next if $zone eq $dst_zone; | ||||
| 12577 | 0 | 0 | next if $intf->{main_interface}; | ||||
| 12578 | 0 | 0 | check_supernet_in_zone($rule, 'src', $intf, $zone, 1); | ||||
| 12579 | } | ||||||
| 12580 | } | ||||||
| 12581 | } | ||||||
| 12582 | } | ||||||
| 12583 | |||||||
| 12584 | # Nothing to do at first router. | ||||||
| 12585 | # zone2 is checked at R2, because we need the no_nat_set at R2. | ||||||
| 12586 | 66 | 166 | return if $src_zone eq $in_zone; | ||||
| 12587 | |||||||
| 12588 | # Check if rule "supernet2 -> dst" is defined. | ||||||
| 12589 | 19 | 36 | check_supernet_in_zone($rule, 'src', $in_intf, $in_zone); | ||||
| 12590 | 19 | 27 | return; | ||||
| 12591 | } | ||||||
| 12592 | |||||||
| 12593 | # If such rule is defined | ||||||
| 12594 | # permit src supernet5 | ||||||
| 12595 | # | ||||||
| 12596 | # and topology is like this: | ||||||
| 12597 | # | ||||||
| 12598 | # /-zone4 | ||||||
| 12599 | # src-R1-zone2-R2-zone3-R3-zone5 | ||||||
| 12600 | # \-zone1 | ||||||
| 12601 | # | ||||||
| 12602 | # additional rules need to be defined as well: | ||||||
| 12603 | # permit src supernet1 | ||||||
| 12604 | # permit src supernet2 | ||||||
| 12605 | # permit src supernet3 | ||||||
| 12606 | # permit src supernet4 | ||||||
| 12607 | sub check_supernet_dst_rule { | ||||||
| 12608 | |||||||
| 12609 | # Function is called from path_walk. | ||||||
| 12610 | 72 | 0 | 77 | my ($rule, $in_intf, $out_intf) = @_; | |||
| 12611 | |||||||
| 12612 | # Source is interface of current router. | ||||||
| 12613 | 72 | 98 | return unless $in_intf; | ||||
| 12614 | |||||||
| 12615 | # Ignore semi_managed router. | ||||||
| 12616 | 71 | 69 | my $router = $in_intf->{router}; | ||||
| 12617 | 71 | 113 | return if not $router->{managed}; | ||||
| 12618 | |||||||
| 12619 | 71 | 65 | my $src = $rule->{src}; | ||||
| 12620 | 71 | 89 | my $src_zone = get_zone($src); | ||||
| 12621 | 71 | 74 | my $dst = $rule->{dst}; | ||||
| 12622 | 71 | 72 | my $dst_zone = $dst->{zone}; | ||||
| 12623 | |||||||
| 12624 | # Check case II, outgoing ACL, (B), interface Y without ACL. | ||||||
| 12625 | 71 | 109 | if (my $no_acl_intf = $router->{no_in_acl}) { | ||||
| 12626 | 7 | 6 | my $no_acl_zone = $no_acl_intf->{zone}; | ||||
| 12627 | |||||||
| 12628 | # a) src behind Y | ||||||
| 12629 | 7 | 20 | if ($no_acl_zone eq $src_zone) { | ||||
| 12630 | } | ||||||
| 12631 | |||||||
| 12632 | # b) src not behind Y | ||||||
| 12633 | # zone X == zone Y | ||||||
| 12634 | elsif ($no_acl_zone eq $dst_zone) { | ||||||
| 12635 | } | ||||||
| 12636 | |||||||
| 12637 | elsif ($no_acl_intf->{main_interface}) { | ||||||
| 12638 | } | ||||||
| 12639 | |||||||
| 12640 | # zone X != zone Y | ||||||
| 12641 | else { | ||||||
| 12642 | 3 | 4 | check_supernet_in_zone($rule, 'dst', $in_intf, $no_acl_zone); | ||||
| 12643 | } | ||||||
| 12644 | 7 | 11 | return; | ||||
| 12645 | } | ||||||
| 12646 | |||||||
| 12647 | # Check security zones at all interfaces except those connected to dst or src. | ||||||
| 12648 | # For devices which have rules for each pair of incoming and outgoing | ||||||
| 12649 | # interfaces we only need to check the direct path to dst. | ||||||
| 12650 | 64 50 | 111 66 | for my $intf ( | ||||
| 12651 | $router->{model}->{has_io_acl} | ||||||
| 12652 | ? ($out_intf) | ||||||
| 12653 | : @{ $router->{interfaces} } | ||||||
| 12654 | ) | ||||||
| 12655 | { | ||||||
| 12656 | |||||||
| 12657 | # Check each intermediate zone only once at outgoing interface. | ||||||
| 12658 | 159 | 302 | next if $intf eq $in_intf; | ||||
| 12659 | 109 | 257 | next if $intf->{loopback} && ! $intf->{vip}; | ||||
| 12660 | |||||||
| 12661 | # Don't check interface where src or dst is attached. | ||||||
| 12662 | 93 | 79 | my $zone = $intf->{zone}; | ||||
| 12663 | 93 | 168 | next if $zone eq $src_zone; | ||||
| 12664 | 92 | 185 | next if $zone eq $dst_zone; | ||||
| 12665 | 46 | 68 | next if $intf->{main_interface}; | ||||
| 12666 | 46 | 64 | check_supernet_in_zone($rule, 'dst', $in_intf, $zone); | ||||
| 12667 | } | ||||||
| 12668 | 64 | 91 | return; | ||||
| 12669 | } | ||||||
| 12670 | |||||||
| 12671 | # Optimization: | ||||||
| 12672 | # Call check_supernet_dst_rule not for every rule with aggregate as destination, | ||||||
| 12673 | # but only once for a set of rules from collect_supernet_dst_rules. | ||||||
| 12674 | sub check_supernet_dst_collections { | ||||||
| 12675 | 226 | 0 | 747 | return if !keys %supernet_rule_tree; | |||
| 12676 | 32 | 34 | my @check_rules; | ||||
| 12677 | |||||||
| 12678 | 32 | 43 | for my $src2href (values %supernet_rule_tree) { | ||||
| 12679 | 32 | 59 | for my $src_range2href (values %$src2href) { | ||||
| 12680 | 36 | 46 | for my $prt2href (values %$src_range2href) { | ||||
| 12681 | 36 | 46 | for my $intf2href (values %$prt2href) { | ||||
| 12682 | 38 | 49 | for my $ipmask2href (values %$intf2href) { | ||||
| 12683 | |||||||
| 12684 | # Check larger aggregates first. To get | ||||||
| 12685 | # deterministic error messages. | ||||||
| 12686 | 45 4 | 85 14 | for my $ipmask (sort { (split '/', $a)[1] <=> | ||||
| 12687 | (split '/', $b)[1] } | ||||||
| 12688 | keys %$ipmask2href) | ||||||
| 12689 | { | ||||||
| 12690 | 48 | 46 | my $zone2rule = $ipmask2href->{$ipmask}; | ||||
| 12691 | 48 | 194 | push @check_rules, (values %$zone2rule )[0]; | ||||
| 12692 | } | ||||||
| 12693 | } | ||||||
| 12694 | } | ||||||
| 12695 | } | ||||||
| 12696 | } | ||||||
| 12697 | } | ||||||
| 12698 | 32 | 37 | for my $rule (@check_rules) { | ||||
| 12699 | 48 | 78 | path_walk($rule, \&check_supernet_dst_rule); | ||||
| 12700 | } | ||||||
| 12701 | |||||||
| 12702 | # Not used any longer. | ||||||
| 12703 | 32 | 107 | %supernet_rule_tree = (); | ||||
| 12704 | 32 | 37 | return; | ||||
| 12705 | } | ||||||
| 12706 | |||||||
| 12707 | # Find smaller protocol of two protocols. | ||||||
| 12708 | # Cache results. | ||||||
| 12709 | my %smaller_prt; | ||||||
| 12710 | |||||||
| 12711 | sub find_smaller_prt { | ||||||
| 12712 | 8 | 0 | 8 | my ($prt1, $prt2) = @_; | |||
| 12713 | |||||||
| 12714 | 8 | 17 | if ($prt1 eq $prt2) { | ||||
| 12715 | 8 | 17 | return $prt1; | ||||
| 12716 | } | ||||||
| 12717 | 0 | 0 | if (defined(my $prt = $smaller_prt{$prt1}->{$prt2})) { | ||||
| 12718 | 0 | 0 | return $prt; | ||||
| 12719 | } | ||||||
| 12720 | |||||||
| 12721 | 0 | 0 | my $prt = $prt1; | ||||
| 12722 | 0 | 0 | while ($prt = $prt->{up}) { | ||||
| 12723 | 0 | 0 | if ($prt eq $prt2) { | ||||
| 12724 | 0 | 0 | $smaller_prt{$prt1}->{$prt2} = $prt1; | ||||
| 12725 | 0 | 0 | $smaller_prt{$prt2}->{$prt1} = $prt1; | ||||
| 12726 | 0 | 0 | return $prt1; | ||||
| 12727 | } | ||||||
| 12728 | } | ||||||
| 12729 | 0 | 0 | $prt = $prt2; | ||||
| 12730 | 0 | 0 | while ($prt = $prt->{up}) { | ||||
| 12731 | 0 | 0 | if ($prt eq $prt1) { | ||||
| 12732 | 0 | 0 | $smaller_prt{$prt1}->{$prt2} = $prt2; | ||||
| 12733 | 0 | 0 | $smaller_prt{$prt2}->{$prt1} = $prt2; | ||||
| 12734 | 0 | 0 | return $prt2; | ||||
| 12735 | } | ||||||
| 12736 | } | ||||||
| 12737 | 0 | 0 | $smaller_prt{$prt1}->{$prt2} = 0; | ||||
| 12738 | 0 | 0 | $smaller_prt{$prt2}->{$prt1} = 0; | ||||
| 12739 | 0 | 0 | return; | ||||
| 12740 | } | ||||||
| 12741 | |||||||
| 12742 | # Example: | ||||||
| 12743 | # XX--R1--any:A--R2--R3--R4--YY | ||||||
| 12744 | # | ||||||
| 12745 | # If we have rules | ||||||
| 12746 | # permit XX any:A | ||||||
| 12747 | # permit any:B YY | ||||||
| 12748 | # and | ||||||
| 12749 | # the intersection I of A and B isn't empty | ||||||
| 12750 | # and | ||||||
| 12751 | # XX and YY are subnet of I | ||||||
| 12752 | # then this traffic is implicitly permitted | ||||||
| 12753 | # permit XX YY | ||||||
| 12754 | # which may be undesired. | ||||||
| 12755 | # In order to avoid this, a warning is generated if the implied rule is not | ||||||
| 12756 | # explicitly defined. | ||||||
| 12757 | # | ||||||
| 12758 | # ToDo: | ||||||
| 12759 | # Do we need to check for {zone_cluster} equality? | ||||||
| 12760 | # | ||||||
| 12761 | # Currently we only check aggregates/supernets with mask = 0. | ||||||
| 12762 | # Checking of other aggregates is too complicate (NAT, intersection). | ||||||
| 12763 | |||||||
| 12764 | # Collect info about unwanted implied rules. | ||||||
| 12765 | sub check_for_transient_supernet_rule { | ||||||
| 12766 | 226 | 0 | 188 | my %missing_rule_tree; | |||
| 12767 | 226 | 207 | my $missing_count = 0; | ||||
| 12768 | |||||||
| 12769 | 226 226 | 185 333 | for my $rule (@{ $expanded_rules{supernet} }) { | ||||
| 12770 | 120 | 190 | next if $rule->{deleted}; | ||||
| 12771 | 112 | 170 | next if $rule->{deny}; | ||||
| 12772 | 112 | 165 | next if $rule->{no_check_supernet_rules}; | ||||
| 12773 | 112 | 96 | my $dst = $rule->{dst}; | ||||
| 12774 | 112 | 201 | next if not $dst->{is_supernet}; | ||||
| 12775 | |||||||
| 12776 | # Check only 0/0 aggregates. | ||||||
| 12777 | 56 | 108 | next if $dst->{mask} != 0; | ||||
| 12778 | |||||||
| 12779 | # A leaf security zone has only one interface. | ||||||
| 12780 | # It can't lead to unwanted rule chains. | ||||||
| 12781 | 26 26 | 20 62 | next if @{ $dst->{zone}->{interfaces} } <= 1; | ||||
| 12782 | |||||||
| 12783 | 8 | 15 | my ($stateless1, $src1, $dst1, $src_range1, $prt1) = | ||||
| 12784 | @$rule{qw(stateless src dst src_range prt)}; | ||||||
| 12785 | 8 | 22 | $stateless1 ||= ''; | ||||
| 12786 | 8 | 9 | my $deny = ''; | ||||
| 12787 | 8 | 19 | $src_range1 ||= $prt_ip; | ||||
| 12788 | |||||||
| 12789 | # Find all rules with supernet as source, which intersect with $dst1. | ||||||
| 12790 | 8 | 7 | my $src2 = $dst1; | ||||
| 12791 | 8 | 8 | for my $stateless2 (1, '') { | ||||
| 12792 | 16 | 29 | my $hash = $rule_tree{$stateless2} or next; | ||||
| 12793 | 8 | 16 | $hash = $hash->{$deny} or next; | ||||
| 12794 | 8 | 20 | while (my ($src_range2_str, $hash) = each %$hash) { | ||||
| 12795 | 8 | 7 | my $src_range2 = $ref2prt{$src_range2_str}; | ||||
| 12796 | 8 | 14 | my $smaller_src_range = | ||||
| 12797 | find_smaller_prt($src_range1, $src_range2) or next; | ||||||
| 12798 | |||||||
| 12799 | 8 | 41 | $hash = $hash->{$src2} or next; | ||||
| 12800 | 0 | 0 | while (my ($dst2_str, $hash) = each %$hash) { | ||||
| 12801 | |||||||
| 12802 | # Skip reverse rules. | ||||||
| 12803 | 0 | 0 | next if $src1 eq $dst2_str; | ||||
| 12804 | |||||||
| 12805 | 0 | 0 | my $dst2 = $ref2obj{$dst2_str}; | ||||
| 12806 | |||||||
| 12807 | # Skip rules with src and dst inside a single zone. | ||||||
| 12808 | 0 | 0 | next if (($obj2zone{$src1} || get_zone $src1) eq | ||||
| 12809 | ($obj2zone{$dst2} || get_zone $dst2)); | ||||||
| 12810 | |||||||
| 12811 | RULE2: | ||||||
| 12812 | 0 | 0 | while (my ($prt2_str, $rule2) = each %$hash) { | ||||
| 12813 | 0 | 0 | next if $rule2->{no_check_supernet_rules}; | ||||
| 12814 | |||||||
| 12815 | 0 | 0 | my $prt2 = $rule2->{prt}; | ||||
| 12816 | 0 | 0 | my $src_range2 = $rule2->{src_range} || $prt_ip; | ||||
| 12817 | |||||||
| 12818 | # Find smaller protocol of two rules found. | ||||||
| 12819 | 0 | 0 | my $smaller_prt = find_smaller_prt($prt1, $prt2); | ||||
| 12820 | |||||||
| 12821 | # If protocols are disjoint, we do not have | ||||||
| 12822 | # transient-supernet-problem for $rule and $rule2. | ||||||
| 12823 | 0 | 0 | next if not $smaller_prt; | ||||
| 12824 | |||||||
| 12825 | # Stateless rule < stateful rule, hence use ||. | ||||||
| 12826 | 0 | 0 | my $stateless = $stateless1 || $stateless2; | ||||
| 12827 | |||||||
| 12828 | # Check for a rule with $src1 and $dst2 and | ||||||
| 12829 | # with $smaller_prt. | ||||||
| 12830 | 0 | 0 | while (1) { | ||||
| 12831 | 0 | 0 | my $deny = ''; | ||||
| 12832 | 0 | 0 | if (my $hash = $rule_tree{$stateless}) { | ||||
| 12833 | 0 | 0 | while (1) { | ||||
| 12834 | 0 | 0 | my $src_range = $smaller_src_range; | ||||
| 12835 | 0 | 0 | if (my $hash = $hash->{$deny}) { | ||||
| 12836 | 0 | 0 | while (1) { | ||||
| 12837 | 0 | 0 | my $src = $src1; | ||||
| 12838 | 0 | 0 | if (my $hash = $hash->{$src_range}) { | ||||
| 12839 | 0 | 0 | while (1) { | ||||
| 12840 | 0 | 0 | my $dst = $dst2; | ||||
| 12841 | 0 | 0 | if (my $hash = $hash->{$src}) { | ||||
| 12842 | 0 | 0 | while (1) { | ||||
| 12843 | 0 | 0 | my $prt = $smaller_prt; | ||||
| 12844 | 0 | 0 | if (my $hash = $hash->{$dst}) { | ||||
| 12845 | 0 | 0 | while (1) { | ||||
| 12846 | 0 | 0 | if (my $other_rule = $hash->{$prt}) { | ||||
| 12847 | |||||||
| 12848 | # debug(print_rule $r_rule); | ||||||
| 12849 | 0 | 0 | next RULE2; | ||||
| 12850 | } | ||||||
| 12851 | 0 | 0 | $prt = $prt->{up} or last; | ||||
| 12852 | } | ||||||
| 12853 | } | ||||||
| 12854 | 0 | 0 | $dst = $dst->{up} or last; | ||||
| 12855 | } | ||||||
| 12856 | } | ||||||
| 12857 | 0 | 0 | $src = $src->{up} or last; | ||||
| 12858 | } | ||||||
| 12859 | } | ||||||
| 12860 | 0 | 0 | $src_range = $src_range->{up} or last; | ||||
| 12861 | } | ||||||
| 12862 | } | ||||||
| 12863 | 0 | 0 | last if $deny; | ||||
| 12864 | 0 | 0 | $deny = 1; | ||||
| 12865 | } | ||||||
| 12866 | } | ||||||
| 12867 | 0 | 0 | last if !$stateless; | ||||
| 12868 | 0 | 0 | $stateless = ''; | ||||
| 12869 | } | ||||||
| 12870 | |||||||
| 12871 | # debug("Src: ", print_rule $rule); | ||||||
| 12872 | # debug("Dst: ", print_rule $rule2); | ||||||
| 12873 | 0 | 0 | my $src_service = $rule->{rule}->{service}->{name}; | ||||
| 12874 | 0 | 0 | my $dst_service = $rule2->{rule}->{service}->{name}; | ||||
| 12875 | 0 | 0 | my $prt_name = $smaller_prt->{name}; | ||||
| 12876 | 0 | 0 | $prt_name =~ s/^.part_/[part]/; | ||||
| 12877 | 0 | 0 | if ($smaller_src_range ne $prt_ip) { | ||||
| 12878 | 0 0 | 0 0 | my ($p1, $p2) = @{ $smaller_src_range->{range} }; | ||||
| 12879 | 0 | 0 | $prt_name = "[src:$p1-$p2]$prt_name"; | ||||
| 12880 | } | ||||||
| 12881 | 0 | 0 | my $new = | ||||
| 12882 | not $missing_rule_tree{$src_service}->{$dst_service} | ||||||
| 12883 | |||||||
| 12884 | # The matching supernet object. | ||||||
| 12885 | ->{ $dst1->{name} } | ||||||
| 12886 | |||||||
| 12887 | # The missing rule | ||||||
| 12888 | ->{ $src1->{name} }->{ $dst2->{name} }->{$prt_name}++; | ||||||
| 12889 | 0 | 0 | $missing_count++ if $new; | ||||
| 12890 | } | ||||||
| 12891 | } | ||||||
| 12892 | } | ||||||
| 12893 | } | ||||||
| 12894 | } | ||||||
| 12895 | |||||||
| 12896 | # No longer needed; free some memory. | ||||||
| 12897 | 226 | 241 | %smaller_prt = (); | ||||
| 12898 | |||||||
| 12899 | 226 | 334 | if ($missing_count) { | ||||
| 12900 | |||||||
| 12901 | 0 | 0 | my $print = | ||||
| 12902 | $config{check_transient_supernet_rules} eq 'warn' | ||||||
| 12903 | ? \&warn_msg | ||||||
| 12904 | : \&err_msg; | ||||||
| 12905 | 0 | 0 | $print->("Missing transient rules: $missing_count"); | ||||
| 12906 | |||||||
| 12907 | 0 | 0 | while (my ($src_service, $hash) = each %missing_rule_tree) { | ||||
| 12908 | 0 | 0 | while (my ($dst_service, $hash) = each %$hash) { | ||||
| 12909 | 0 | 0 | while (my ($supernet, $hash) = each %$hash) { | ||||
| 12910 | 0 | 0 | info | ||||
| 12911 | "Rules of $src_service and $dst_service match at $supernet"; | ||||||
| 12912 | 0 | 0 | info("Missing transient rules:"); | ||||
| 12913 | 0 | 0 | while (my ($src, $hash) = each %$hash) { | ||||
| 12914 | 0 | 0 | while (my ($dst, $hash) = each %$hash) { | ||||
| 12915 | 0 | 0 | while (my ($prt, $hash) = each %$hash) { | ||||
| 12916 | 0 | 0 | info(" permit src=$src; dst=$dst; prt=$prt"); | ||||
| 12917 | } | ||||||
| 12918 | } | ||||||
| 12919 | } | ||||||
| 12920 | } | ||||||
| 12921 | } | ||||||
| 12922 | } | ||||||
| 12923 | } | ||||||
| 12924 | 226 | 251 | return; | ||||
| 12925 | } | ||||||
| 12926 | |||||||
| 12927 | # Handling of supernet rules created by gen_reverse_rules. | ||||||
| 12928 | # This is not needed if a stateful and not secondary packet filter is | ||||||
| 12929 | # located on the path between src and dst. | ||||||
| 12930 | # | ||||||
| 12931 | # 1. dst is supernet | ||||||
| 12932 | # | ||||||
| 12933 | # src--r1:stateful--dst1=supernet1--r2:stateless--dst2=supernet2 | ||||||
| 12934 | # | ||||||
| 12935 | # gen_reverse_rule will create one additional rule | ||||||
| 12936 | # supernet2-->src, but not a rule supernet1-->src, because r1 is stateful. | ||||||
| 12937 | # check_supernet_src_rule would complain, that supernet1-->src is missing. | ||||||
| 12938 | # But that doesn't matter, because r1 would permit answer packets | ||||||
| 12939 | # from supernet2 anyway, because it's stateful. | ||||||
| 12940 | # Hence we can skip check_supernet_src_rule for this situation. | ||||||
| 12941 | # | ||||||
| 12942 | # 2. src is supernet | ||||||
| 12943 | # | ||||||
| 12944 | # a) no stateful router on the path between stateless routers and dst. | ||||||
| 12945 | # | ||||||
| 12946 | # zone2---\ | ||||||
| 12947 | # src=supernet1--r1:stateless--dst | ||||||
| 12948 | # | ||||||
| 12949 | # gen_reverse_rules will create one additional rule dst-->supernet1. | ||||||
| 12950 | # check_supernet_dst_rule would complain about a missing rule | ||||||
| 12951 | # dst-->zone2. | ||||||
| 12952 | # To prevent this situation, check_supernet_src_rule checks for a rule | ||||||
| 12953 | # zone2 --> dst | ||||||
| 12954 | # | ||||||
| 12955 | # b) at least one stateful router on the path between | ||||||
| 12956 | # stateless router and dst. | ||||||
| 12957 | # | ||||||
| 12958 | # zone3---\ | ||||||
| 12959 | # src1=supernet1--r1:stateless--src2=supernet2--r2:stateful--dst | ||||||
| 12960 | # | ||||||
| 12961 | # gen_reverse_rules will create one additional rule | ||||||
| 12962 | # dst-->supernet1, but not dst-->supernet2 because second router is stateful. | ||||||
| 12963 | # check_supernet_dst_rule would complain about missing rules | ||||||
| 12964 | # dst-->supernet2 and dst-->supernet3. | ||||||
| 12965 | # But answer packets back from dst have been filtered by r2 already, | ||||||
| 12966 | # hence it doesn't hurt if the rules at r1 are a bit too relaxed, | ||||||
| 12967 | # i.e. r1 would permit dst to zone1 and zone3, but should only | ||||||
| 12968 | # permit dst to zone1. | ||||||
| 12969 | # Hence we can skip check_supernet_dst_rule for this situation. | ||||||
| 12970 | # | ||||||
| 12971 | |||||||
| 12972 | # Mark zones connected by stateless or secondary packet filters or by | ||||||
| 12973 | # semi_managed devices. | ||||||
| 12974 | sub mark_stateful { | ||||||
| 12975 | 658 | 0 | 584 | my ($zone, $mark) = @_; | |||
| 12976 | 658 | 665 | $zone->{stateful_mark} = $mark; | ||||
| 12977 | 658 658 | 497 800 | for my $in_interface (@{ $zone->{interfaces} }) { | ||||
| 12978 | 887 | 781 | my $router = $in_interface->{router}; | ||||
| 12979 | 887 | 1232 | if ($router->{managed}) { | ||||
| 12980 | next | ||||||
| 12981 | 850 | 3007 | if !$router->{model}->{stateless} | ||||
| 12982 | && $router->{managed} !~ /^(?:secondary|local.*)$/; | ||||||
| 12983 | } | ||||||
| 12984 | 237 | 434 | next if $router->{active_path}; | ||||
| 12985 | 115 | 170 | local $router->{active_path} = 1; | ||||
| 12986 | 115 115 | 98 146 | for my $out_interface (@{ $router->{interfaces} }) { | ||||
| 12987 | 260 | 594 | next if $out_interface eq $in_interface; | ||||
| 12988 | 145 | 129 | my $next_zone = $out_interface->{zone}; | ||||
| 12989 | 145 | 237 | next if $next_zone->{stateful_mark}; | ||||
| 12990 | 116 | 198 | mark_stateful($next_zone, $mark); | ||||
| 12991 | } | ||||||
| 12992 | } | ||||||
| 12993 | 658 | 1036 | return; | ||||
| 12994 | } | ||||||
| 12995 | |||||||
| 12996 | sub check_supernet_rules { | ||||||
| 12997 | 226 | 0 | 403 | if ($config{check_supernet_rules}) { | |||
| 12998 | 226 120 226 | 206 182 300 | my $count = grep { !$_->{deleted} } @{ $expanded_rules{supernet} }; | ||||
| 12999 | 226 | 514 | progress("Checking $count rules with supernet objects"); | ||||
| 13000 | 226 | 215 | my $stateful_mark = 1; | ||||
| 13001 | 226 | 259 | for my $zone (@zones) { | ||||
| 13002 | 658 | 1016 | if (not $zone->{stateful_mark}) { | ||||
| 13003 | 542 | 740 | mark_stateful($zone, $stateful_mark++); | ||||
| 13004 | } | ||||||
| 13005 | } | ||||||
| 13006 | 226 226 | 213 322 | for my $rule (@{ $expanded_rules{supernet} }) { | ||||
| 13007 | 120 | 200 | next if $rule->{deleted}; | ||||
| 13008 | 112 | 162 | next if $rule->{no_check_supernet_rules}; | ||||
| 13009 | 112 | 200 | if ($rule->{src}->{is_supernet}) { | ||||
| 13010 | 63 | 106 | path_walk($rule, \&check_supernet_src_rule); | ||||
| 13011 | } | ||||||
| 13012 | 112 | 228 | if ($rule->{dst}->{is_supernet}) { | ||||
| 13013 | 56 | 97 | path_walk($rule, \&collect_supernet_dst_rules); | ||||
| 13014 | } | ||||||
| 13015 | } | ||||||
| 13016 | 226 | 347 | check_supernet_dst_collections(); | ||||
| 13017 | 226 | 283 | %missing_supernet = (); | ||||
| 13018 | } | ||||||
| 13019 | 226 | 388 | if ($config{check_transient_supernet_rules}) { | ||||
| 13020 | 226 | 302 | check_for_transient_supernet_rule(); | ||||
| 13021 | } | ||||||
| 13022 | |||||||
| 13023 | # no longer needed; free some memory. | ||||||
| 13024 | 226 | 279 | %obj2zone = (); | ||||
| 13025 | 226 | 185 | return; | ||||
| 13026 | } | ||||||
| 13027 | |||||||
| 13028 | ############################################################################## | ||||||
| 13029 | # Generate reverse rules for stateless packet filters: | ||||||
| 13030 | # For each rule with protocol tcp, udp or ip we need a reverse rule | ||||||
| 13031 | # with swapped src, dst and src-port, dst-port. | ||||||
| 13032 | # For rules with a tcp protocol, the reverse rule gets a tcp protocol | ||||||
| 13033 | # without range checking but with checking for 'established` flag. | ||||||
| 13034 | ############################################################################## | ||||||
| 13035 | |||||||
| 13036 | sub gen_reverse_rules1 { | ||||||
| 13037 | 678 | 0 | 577 | my ($rule_aref, $rule_tree) = @_; | |||
| 13038 | 678 | 478 | my @extra_rules; | ||||
| 13039 | my %cache; | ||||||
| 13040 | 678 | 732 | for my $rule (@$rule_aref) { | ||||
| 13041 | 524 | 821 | if ($rule->{deleted}) { | ||||
| 13042 | 21 | 20 | my $src = $rule->{src}; | ||||
| 13043 | |||||||
| 13044 | # If source is a managed interface, | ||||||
| 13045 | # reversed will get attribute managed_intf. | ||||||
| 13046 | 21 | 30 | unless (is_interface($src) && ($src->{router}->{managed} || | ||||
| 13047 | $src->{router}->{routing_only})) | ||||||
| 13048 | { | ||||||
| 13049 | 21 | 33 | next; | ||||
| 13050 | } | ||||||
| 13051 | } | ||||||
| 13052 | 503 | 455 | my $prt = $rule->{prt}; | ||||
| 13053 | 503 | 497 | my $proto = $prt->{proto}; | ||||
| 13054 | 503 | 1306 | next unless $proto eq 'tcp' or $proto eq 'udp' or $proto eq 'ip'; | ||||
| 13055 | 447 | 618 | next if $rule->{oneway}; | ||||
| 13056 | |||||||
| 13057 | # No reverse rules will be generated for denied TCP packets, because | ||||||
| 13058 | # - there can't be an answer if the request is already denied and | ||||||
| 13059 | # - the 'established' optimization for TCP below would produce | ||||||
| 13060 | # wrong results. | ||||||
| 13061 | 447 | 1244 | next if $proto eq 'tcp' and $rule->{deny}; | ||||
| 13062 | |||||||
| 13063 | 447 | 377 | my $src = $rule->{src}; | ||||
| 13064 | 447 | 372 | my $dst = $rule->{dst}; | ||||
| 13065 | 447 | 948 | my $from_store = $obj2path{$src} || get_path $src; | ||||
| 13066 | 447 | 868 | my $to_store = $obj2path{$dst} || get_path $dst; | ||||
| 13067 | 447 | 721 | my $has_stateless_router = $cache{$from_store}->{$to_store}; | ||||
| 13068 | 447 | 658 | if (!defined $has_stateless_router) { | ||||
| 13069 | PATH_WALK: | ||||||
| 13070 | { | ||||||
| 13071 | |||||||
| 13072 | # Local function. | ||||||
| 13073 | # It uses free variable $has_stateless_router. | ||||||
| 13074 | 287 | 228 | my $mark_reverse_rule = sub { | ||||
| 13075 | 433 | 434 | my ($rule, $in_intf, $out_intf) = @_; | ||||
| 13076 | |||||||
| 13077 | # Destination of current rule is current router. | ||||||
| 13078 | # Outgoing packets from a router itself are never filtered. | ||||||
| 13079 | # Hence we don't need a reverse rule for current router. | ||||||
| 13080 | 433 | 625 | return if not $out_intf; | ||||
| 13081 | 379 | 363 | my $router = $out_intf->{router}; | ||||
| 13082 | |||||||
| 13083 | # It doesn't matter if a semi_managed device is stateless | ||||||
| 13084 | # because no code is generated. | ||||||
| 13085 | 379 | 557 | return if not $router->{managed}; | ||||
| 13086 | 367 | 347 | my $model = $router->{model}; | ||||
| 13087 | |||||||
| 13088 | 367 | 1170 | if ( | ||||
| 13089 | $model->{stateless} | ||||||
| 13090 | |||||||
| 13091 | # Source of current rule is current router. | ||||||
| 13092 | or not $in_intf and $model->{stateless_self} | ||||||
| 13093 | ) | ||||||
| 13094 | { | ||||||
| 13095 | 66 | 55 | $has_stateless_router = 1; | ||||
| 13096 | |||||||
| 13097 | # Jump out of path_walk. | ||||||
| 13098 | 70 70 70 | 463 100 2482621 | no warnings "exiting"; ## no critic (ProhibitNoWarn) | ||||
| 13099 | 66 | 141 | last PATH_WALK if $use_nonlocal_exit; | ||||
| 13100 | } | ||||||
| 13101 | 287 | 839 | }; | ||||
| 13102 | 287 | 424 | path_walk($rule, $mark_reverse_rule); | ||||
| 13103 | } | ||||||
| 13104 | 287 | 1019 | $cache{$from_store}->{$to_store} = $has_stateless_router || 0; | ||||
| 13105 | } | ||||||
| 13106 | 447 | 938 | if ($has_stateless_router) { | ||||
| 13107 | 69 | 116 | my $new_src_range; | ||||
| 13108 | my $new_prt; | ||||||
| 13109 | 69 | 118 | if ($proto eq 'tcp') { | ||||
| 13110 | 49 | 56 | $new_prt = $range_tcp_established; | ||||
| 13111 | } | ||||||
| 13112 | elsif ($proto eq 'udp') { | ||||||
| 13113 | |||||||
| 13114 | # Swap src and dst range. | ||||||
| 13115 | 13 | 12 | $new_src_range = $rule->{prt}; | ||||
| 13116 | 13 | 29 | if ($new_src_range->{range} eq $aref_tcp_any) { | ||||
| 13117 | 1 | 1 | $new_src_range = undef; | ||||
| 13118 | } | ||||||
| 13119 | 13 | 16 | $new_prt = $rule->{src_range}; | ||||
| 13120 | 13 | 19 | if (not $new_prt) { | ||||
| 13121 | 5 | 6 | $new_prt = $prt_udp->{dst_range}; | ||||
| 13122 | } | ||||||
| 13123 | } | ||||||
| 13124 | elsif ($proto eq 'ip') { | ||||||
| 13125 | 7 | 5 | $new_prt = $prt; | ||||
| 13126 | } | ||||||
| 13127 | else { | ||||||
| 13128 | 0 | 0 | internal_err(); | ||||
| 13129 | } | ||||||
| 13130 | 69 | 143 | my $new_rule = { | ||||
| 13131 | |||||||
| 13132 | # This rule must only be applied to stateless routers. | ||||||
| 13133 | stateless => 1, | ||||||
| 13134 | src => $dst, | ||||||
| 13135 | dst => $src, | ||||||
| 13136 | prt => $new_prt, | ||||||
| 13137 | }; | ||||||
| 13138 | 69 | 107 | $new_rule->{src_range} = $new_src_range if $new_src_range; | ||||
| 13139 | 69 | 116 | $new_rule->{deny} = 1 if $rule->{deny}; | ||||
| 13140 | |||||||
| 13141 | # Don't push to @$rule_aref while we are iterating over it. | ||||||
| 13142 | 69 | 143 | push @extra_rules, $new_rule; | ||||
| 13143 | } | ||||||
| 13144 | } | ||||||
| 13145 | 678 | 629 | push @$rule_aref, @extra_rules; | ||||
| 13146 | 678 | 841 | add_rules(\@extra_rules, $rule_tree); | ||||
| 13147 | 678 | 1095 | return; | ||||
| 13148 | } | ||||||
| 13149 | |||||||
| 13150 | sub gen_reverse_rules { | ||||||
| 13151 | 226 | 0 | 299 | progress('Generating reverse rules for stateless routers'); | |||
| 13152 | 226 | 183 | my %reverse_rule_tree; | ||||
| 13153 | 226 | 271 | for my $type ('deny', 'supernet', 'permit') { | ||||
| 13154 | 678 | 1029 | gen_reverse_rules1($expanded_rules{$type}, \%reverse_rule_tree); | ||||
| 13155 | } | ||||||
| 13156 | 226 | 473 | if (keys %reverse_rule_tree) { | ||||
| 13157 | 38 | 56 | print_rulecount; | ||||
| 13158 | 38 | 51 | progress('Optimizing reverse rules'); | ||||
| 13159 | 38 | 60 | optimize_rules(\%rule_tree, \%reverse_rule_tree); | ||||
| 13160 | 38 | 52 | print_rulecount; | ||||
| 13161 | } | ||||||
| 13162 | |||||||
| 13163 | # Not longer used, free memory. | ||||||
| 13164 | 226 | 584 | %rule_tree = (); | ||||
| 13165 | 226 | 302 | return; | ||||
| 13166 | } | ||||||
| 13167 | |||||||
| 13168 | ############################################################################## | ||||||
| 13169 | # Mark rules for secondary filtering. | ||||||
| 13170 | # A rule is implemented at a device | ||||||
| 13171 | # either as a 'typical' or as a 'secondary' filter. | ||||||
| 13172 | # A filter is called to be 'secondary' if it only checks | ||||||
| 13173 | # for the source and destination network and not for the protocol. | ||||||
| 13174 | # A typical filter checks for full source and destination IP and | ||||||
| 13175 | # for the protocol of the rule. | ||||||
| 13176 | # | ||||||
| 13177 | # There are four types of packet filters: secondary, standard, full, primary. | ||||||
| 13178 | # A rule is marked by two attributes which are determined by the type of | ||||||
| 13179 | # devices located on the path from source to destination. | ||||||
| 13180 | # - 'some_primary': at least one device is primary packet filter, | ||||||
| 13181 | # - 'some_non_secondary': at least one device is not secondary packet filter. | ||||||
| 13182 | # A rule is implemented as a secondary filter at a device if | ||||||
| 13183 | # - the device is secondary and the rule has attribute 'some_non_secondary' or | ||||||
| 13184 | # - the device is standard and the rule has attribute 'some_primary'. | ||||||
| 13185 | # Otherwise a rules is implemented typical. | ||||||
| 13186 | ############################################################################## | ||||||
| 13187 | |||||||
| 13188 | sub get_zone2 { | ||||||
| 13189 | 1944 | 0 | 1477 | my ($obj) = @_; | |||
| 13190 | 1944 | 1676 | my $type = ref $obj; | ||||
| 13191 | 1944 | 3029 | if ($type eq 'Network') { | ||||
| 13192 | 1202 | 1427 | return $obj->{zone}; | ||||
| 13193 | } | ||||||
| 13194 | elsif ($type eq 'Subnet') { | ||||||
| 13195 | 201 | 273 | return $obj->{network}->{zone}; | ||||
| 13196 | } | ||||||
| 13197 | elsif ($type eq 'Interface') { | ||||||
| 13198 | 541 | 657 | return $obj->{network}->{zone}; | ||||
| 13199 | } | ||||||
| 13200 | } | ||||||
| 13201 | |||||||
| 13202 | # Mark security zone $zone with $mark and | ||||||
| 13203 | # additionally mark all security zones | ||||||
| 13204 | # which are connected with $zone by secondary packet filters. | ||||||
| 13205 | sub mark_secondary; | ||||||
| 13206 | |||||||
| 13207 | sub mark_secondary { | ||||||
| 13208 | 658 | 0 | 544 | my ($zone, $mark) = @_; | |||
| 13209 | 658 | 667 | $zone->{secondary_mark} = $mark; | ||||
| 13210 | |||||||
| 13211 | # debug("$zone->{name} $mark"); | ||||||
| 13212 | 658 658 | 499 783 | for my $in_interface (@{ $zone->{interfaces} }) { | ||||
| 13213 | 887 | 1285 | next if $in_interface->{main_interface}; | ||||
| 13214 | 845 | 713 | my $router = $in_interface->{router}; | ||||
| 13215 | 845 | 1280 | if (my $managed = $router->{managed}) { | ||||
| 13216 | 809 | 2252 | next if $managed !~ /^(?:secondary|local.*)$/; | ||||
| 13217 | } | ||||||
| 13218 | 116 | 227 | next if $router->{active_path}; | ||||
| 13219 | 54 | 80 | local $router->{active_path} = 1; | ||||
| 13220 | 54 54 | 46 68 | for my $out_interface (@{ $router->{interfaces} }) { | ||||
| 13221 | 121 | 280 | next if $out_interface eq $in_interface; | ||||
| 13222 | 67 | 101 | next if $out_interface->{main_interface}; | ||||
| 13223 | 64 | 59 | my $next_zone = $out_interface->{zone}; | ||||
| 13224 | 64 | 98 | next if $next_zone->{secondary_mark}; | ||||
| 13225 | 62 | 107 | mark_secondary $next_zone, $mark; | ||||
| 13226 | } | ||||||
| 13227 | } | ||||||
| 13228 | 658 | 805 | return; | ||||
| 13229 | } | ||||||
| 13230 | |||||||
| 13231 | # Mark security zone $zone with $mark and | ||||||
| 13232 | # additionally mark all security zones | ||||||
| 13233 | # which are connected with $zone by non-primary packet filters. | ||||||
| 13234 | # Test for {active_path} has been added to prevent deep recursion. | ||||||
| 13235 | sub mark_primary; | ||||||
| 13236 | |||||||
| 13237 | sub mark_primary { | ||||||
| 13238 | 658 | 0 | 563 | my ($zone, $mark) = @_; | |||
| 13239 | 658 | 650 | $zone->{primary_mark} = $mark; | ||||
| 13240 | 658 658 | 467 786 | for my $in_interface (@{ $zone->{interfaces} }) { | ||||
| 13241 | 887 | 1229 | next if $in_interface->{main_interface}; | ||||
| 13242 | 845 | 724 | my $router = $in_interface->{router}; | ||||
| 13243 | 845 | 1213 | if (my $managed = $router->{managed}) { | ||||
| 13244 | 809 | 1153 | next if $managed eq 'primary'; | ||||
| 13245 | } | ||||||
| 13246 | 843 | 1425 | next if $router->{active_path}; | ||||
| 13247 | 412 | 525 | local $router->{active_path} = 1; | ||||
| 13248 | 412 412 | 310 497 | for my $out_interface (@{ $router->{interfaces} }) { | ||||
| 13249 | 999 | 1978 | next if $out_interface eq $in_interface; | ||||
| 13250 | 587 | 873 | next if $out_interface->{main_interface}; | ||||
| 13251 | 526 | 460 | my $next_zone = $out_interface->{zone}; | ||||
| 13252 | 526 | 785 | next if $next_zone->{primary_mark}; | ||||
| 13253 | 419 | 573 | mark_primary $next_zone, $mark; | ||||
| 13254 | } | ||||||
| 13255 | } | ||||||
| 13256 | 658 | 1102 | return; | ||||
| 13257 | } | ||||||
| 13258 | |||||||
| 13259 | # Mark security zone $zone with $mark and | ||||||
| 13260 | # additionally mark all security zones | ||||||
| 13261 | # which are connected with $zone by non-strict-secondary | ||||||
| 13262 | # packet filters. | ||||||
| 13263 | sub mark_strict_secondary; | ||||||
| 13264 | |||||||
| 13265 | sub mark_strict_secondary { | ||||||
| 13266 | 658 | 0 | 542 | my ($zone, $mark) = @_; | |||
| 13267 | 658 | 660 | $zone->{strict_secondary_mark} = $mark; | ||||
| 13268 | # debug "$zone->{name} : $mark"; | ||||||
| 13269 | 658 658 | 479 774 | for my $in_interface (@{ $zone->{interfaces} }) { | ||||
| 13270 | 887 | 1220 | next if $in_interface->{main_interface}; | ||||
| 13271 | 845 | 703 | my $router = $in_interface->{router}; | ||||
| 13272 | 845 | 1197 | if ($router->{managed}) { | ||||
| 13273 | 809 | 1110 | next if $router->{strict_secondary}; | ||||
| 13274 | } | ||||||
| 13275 | 845 | 1399 | next if $router->{active_path}; | ||||
| 13276 | 413 | 491 | local $router->{active_path} = 1; | ||||
| 13277 | 413 413 | 294 477 | for my $out_interface (@{ $router->{interfaces} }) { | ||||
| 13278 | 1001 | 1916 | next if $out_interface eq $in_interface; | ||||
| 13279 | 588 | 849 | next if $out_interface->{main_interface}; | ||||
| 13280 | 527 | 456 | my $next_zone = $out_interface->{zone}; | ||||
| 13281 | 527 | 803 | next if $next_zone->{strict_secondary_mark}; | ||||
| 13282 | 420 | 537 | mark_strict_secondary($next_zone, $mark); | ||||
| 13283 | } | ||||||
| 13284 | } | ||||||
| 13285 | 658 | 1040 | return; | ||||
| 13286 | } | ||||||
| 13287 | |||||||
| 13288 | # Mark security zone $zone with $mark and additionally mark all | ||||||
| 13289 | # security zones which are connected with $zone by local_secondary | ||||||
| 13290 | # packet filters. | ||||||
| 13291 | sub mark_local_secondary; | ||||||
| 13292 | |||||||
| 13293 | sub mark_local_secondary { | ||||||
| 13294 | 658 | 0 | 523 | my ($zone, $mark) = @_; | |||
| 13295 | 658 | 660 | $zone->{local_secondary_mark} = $mark; | ||||
| 13296 | # debug "local_secondary $zone->{name} : $mark"; | ||||||
| 13297 | 658 658 | 492 750 | for my $in_interface (@{ $zone->{interfaces} }) { | ||||
| 13298 | 887 | 1272 | next if $in_interface->{main_interface}; | ||||
| 13299 | 845 | 670 | my $router = $in_interface->{router}; | ||||
| 13300 | 845 | 1247 | if (my $managed = $router->{managed}) { | ||||
| 13301 | 809 | 1566 | next if $managed ne 'local_secondary'; | ||||
| 13302 | } | ||||||
| 13303 | 46 | 92 | next if $router->{active_path}; | ||||
| 13304 | 21 | 27 | local $router->{active_path} = 1; | ||||
| 13305 | 21 21 | 24 31 | for my $out_interface (@{ $router->{interfaces} }) { | ||||
| 13306 | 47 | 101 | next if $out_interface eq $in_interface; | ||||
| 13307 | 26 | 50 | next if $out_interface->{main_interface}; | ||||
| 13308 | 25 | 21 | my $next_zone = $out_interface->{zone}; | ||||
| 13309 | 25 | 44 | next if $next_zone->{local_secondary_mark}; | ||||
| 13310 | 25 | 47 | mark_local_secondary($next_zone, $mark); | ||||
| 13311 | } | ||||||
| 13312 | } | ||||||
| 13313 | 658 | 907 | return; | ||||
| 13314 | } | ||||||
| 13315 | |||||||
| 13316 | sub mark_secondary_rules { | ||||||
| 13317 | 226 | 0 | 306 | progress('Marking rules for secondary optimization'); | |||
| 13318 | |||||||
| 13319 | 226 | 195 | my $secondary_mark = 1; | ||||
| 13320 | 226 | 189 | my $primary_mark = 1; | ||||
| 13321 | 226 | 182 | my $strict_secondary_mark = 1; | ||||
| 13322 | 226 | 185 | my $local_secondary_mark = 1; | ||||
| 13323 | 226 | 261 | for my $zone (@zones) { | ||||
| 13324 | 658 | 970 | if (not $zone->{secondary_mark}) { | ||||
| 13325 | 596 | 824 | mark_secondary $zone, $secondary_mark++; | ||||
| 13326 | } | ||||||
| 13327 | 658 | 1064 | if (not $zone->{primary_mark}) { | ||||
| 13328 | 239 | 372 | mark_primary $zone, $primary_mark++; | ||||
| 13329 | } | ||||||
| 13330 | 658 | 995 | if (not $zone->{strict_secondary_mark}) { | ||||
| 13331 | 238 | 334 | mark_strict_secondary($zone, $strict_secondary_mark++); | ||||
| 13332 | } | ||||||
| 13333 | 658 | 973 | if (not $zone->{local_secondary_mark}) { | ||||
| 13334 | 633 | 817 | mark_local_secondary($zone, $local_secondary_mark++); | ||||
| 13335 | } | ||||||
| 13336 | } | ||||||
| 13337 | |||||||
| 13338 | # Mark only normal rules for secondary optimization. | ||||||
| 13339 | # Don't modify a deny rule from e.g. tcp to ip. | ||||||
| 13340 | # Don't modify supernet rules, because path isn't fully known. | ||||||
| 13341 | 226 226 226 | 219 263 306 | for my $rule (@{ $expanded_rules{permit} }, @{ $expanded_rules{supernet} }) | ||||
| 13342 | { | ||||||
| 13343 | next | ||||||
| 13344 | 593 | 955 | if $rule->{deleted} | ||||
| 13345 | and | ||||||
| 13346 | (not $rule->{managed_intf} or $rule->{deleted}->{managed_intf}); | ||||||
| 13347 | |||||||
| 13348 | 560 560 | 433 669 | my ($src, $dst) = @{$rule}{qw(src dst)}; | ||||
| 13349 | 560 | 1663 | next if $src->{is_aggregate} || $dst->{is_aggregate}; | ||||
| 13350 | 468 | 524 | my $src_zone = get_zone2($src); | ||||
| 13351 | 468 | 516 | my $dst_zone = get_zone2($dst); | ||||
| 13352 | |||||||
| 13353 | 468 | 1129 | if ($src_zone->{secondary_mark} != $dst_zone->{secondary_mark} || | ||||
| 13354 | |||||||
| 13355 | # Local secondary optimization. | ||||||
| 13356 | $src_zone->{local_mark} && $dst_zone->{local_mark} && | ||||||
| 13357 | $src_zone->{local_mark} == $dst_zone->{local_mark} && | ||||||
| 13358 | $src_zone->{local_secondary_mark} != | ||||||
| 13359 | $dst_zone->{local_secondary_mark}) | ||||||
| 13360 | { | ||||||
| 13361 | 359 | 394 | $rule->{some_non_secondary} = 1; | ||||
| 13362 | } | ||||||
| 13363 | 468 | 758 | if ($src_zone->{primary_mark} != $dst_zone->{primary_mark}) { | ||||
| 13364 | 1 | 2 | $rule->{some_primary} = 1; | ||||
| 13365 | } | ||||||
| 13366 | |||||||
| 13367 | # A device with attribute 'strict_secondary' is located | ||||||
| 13368 | # between src and dst. | ||||||
| 13369 | # Each rule must | ||||||
| 13370 | # - either be optimized secondary | ||||||
| 13371 | # - or be simple: | ||||||
| 13372 | # - protocol IP | ||||||
| 13373 | # - src and dst be either | ||||||
| 13374 | # - network | ||||||
| 13375 | # - loopback interface | ||||||
| 13376 | # - interface of managed device | ||||||
| 13377 | 468 | 966 | if ($src_zone->{strict_secondary_mark} != | ||||
| 13378 | $dst_zone->{strict_secondary_mark}) | ||||||
| 13379 | { | ||||||
| 13380 | 1 | 3 | if (!$rule->{some_non_secondary}) { | ||||
| 13381 | 0 | 0 | my $err; | ||||
| 13382 | 0 | 0 | my ($src, $dst, $prt) = | ||||
| 13383 | 0 | 0 | @{$rule}{ qw(src dst prt) }; | ||||
| 13384 | 0 | 0 | if ($prt ne $prt_ip) { | ||||
| 13385 | 0 | 0 | $err = "'prt = ip'"; | ||||
| 13386 | } | ||||||
| 13387 | else { | ||||||
| 13388 | 0 | 0 | for my $where (qw(src dst)) { | ||||
| 13389 | 0 | 0 | my $what = $rule->{$where}; | ||||
| 13390 | 0 | 0 | if (!is_network($what) && | ||||
| 13391 | !(is_interface($what) && | ||||||
| 13392 | ($what->{loopback} || | ||||||
| 13393 | $what->{router}->{managed}))) | ||||||
| 13394 | { | ||||||
| 13395 | 0 | 0 | $err = | ||||
| 13396 | "network or managed/loopback interface as " | ||||||
| 13397 | . $where; | ||||||
| 13398 | 0 | 0 | last; | ||||
| 13399 | } | ||||||
| 13400 | } | ||||||
| 13401 | } | ||||||
| 13402 | 0 | 0 | if ($err) { | ||||
| 13403 | 0 | 0 | err_msg("Invalid rule at router with attribute", | ||||
| 13404 | " 'strict_secondary'.\n", | ||||||
| 13405 | " Rule must only use $err.\n ", print_rule($rule)); | ||||||
| 13406 | } | ||||||
| 13407 | } | ||||||
| 13408 | } | ||||||
| 13409 | } | ||||||
| 13410 | 226 | 268 | return; | ||||
| 13411 | } | ||||||
| 13412 | |||||||
| 13413 | |||||||
| 13414 | # - Check for partially applied hidden or dynamic NAT on path. | ||||||
| 13415 | # - Check for invalid rules accessing hidden objects. | ||||||
| 13416 | # - Find rules where dynamic NAT is applied to host or interface at | ||||||
| 13417 | # src or dst on path to other end of rule. | ||||||
| 13418 | # Mark found rule with attribute {dynamic_nat} and value src|dst|src,dst. | ||||||
| 13419 | sub mark_dynamic_nat_rules { | ||||||
| 13420 | 226 | 0 | 289 | progress('Marking rules with dynamic NAT'); | |||
| 13421 | |||||||
| 13422 | # Mapping from nat_tag to boolean. | ||||||
| 13423 | # Value is true if hidden NAT, false if dynamic NAT. | ||||||
| 13424 | 226 | 198 | my %dynamic_nat2hidden; | ||||
| 13425 | 226 | 253 | for my $network (@networks) { | ||||
| 13426 | 938 | 1536 | my $href = $network->{nat} or next; | ||||
| 13427 | 69 | 142 | for my $nat_tag (sort keys %$href) { | ||||
| 13428 | 76 | 81 | my $nat_network = $href->{$nat_tag}; | ||||
| 13429 | 76 | 140 | $nat_network->{dynamic} or next; | ||||
| 13430 | 53 | 115 | $dynamic_nat2hidden{$nat_tag} = $nat_network->{hidden}; | ||||
| 13431 | } | ||||||
| 13432 | } | ||||||
| 13433 | |||||||
| 13434 | # Check path for partially applied hidden or dynamic NAT. | ||||||
| 13435 | my $check_dyn_nat = sub { | ||||||
| 13436 | 61 | 66 | my ($rule, $in_intf, $out_intf) = @_; | ||||
| 13437 | 61 | 99 | my $no_nat_set1 = $in_intf ? $in_intf->{no_nat_set} : undef; | ||||
| 13438 | 61 | 75 | my $no_nat_set2 = $out_intf ? $out_intf->{no_nat_set} : undef; | ||||
| 13439 | 61 | 93 | for my $nat_tag (keys %dynamic_nat2hidden) { | ||||
| 13440 | 67 | 96 | if ($no_nat_set1) { | ||||
| 13441 | 39 | 68 | $no_nat_set1->{$nat_tag} or | ||||
| 13442 | 64 | 111 | push @{ $rule->{active_nat_at}->{$nat_tag} }, $in_intf; | ||||
| 13443 | } | ||||||
| 13444 | 67 | 98 | if ($no_nat_set2) { | ||||
| 13445 | 29 | 74 | $no_nat_set2->{$nat_tag} or | ||||
| 13446 | 63 | 137 | push @{ $rule->{active_nat_at}->{$nat_tag} }, $out_intf; | ||||
| 13447 | } | ||||||
| 13448 | } | ||||||
| 13449 | 226 | 766 | }; | ||||
| 13450 | |||||||
| 13451 | 226 | 207 | my %cache; | ||||
| 13452 | |||||||
| 13453 | 226 226 | 199 268 | for my $rule ( | ||||
| 13454 | 226 | 242 | @{ $expanded_rules{permit} }, | ||||
| 13455 | 226 | 301 | @{ $expanded_rules{supernet} }, | ||||
| 13456 | @{ $expanded_rules{deny} } | ||||||
| 13457 | ) | ||||||
| 13458 | { | ||||||
| 13459 | next | ||||||
| 13460 | 593 | 942 | if $rule->{deleted} | ||||
| 13461 | and | ||||||
| 13462 | (not $rule->{managed_intf} or $rule->{deleted}->{managed_intf}); | ||||||
| 13463 | |||||||
| 13464 | 560 | 384 | my $dynamic_nat; | ||||
| 13465 | 560 | 509 | for my $where ('src', 'dst') { | ||||
| 13466 | 1120 | 991 | my $obj = $rule->{$where}; | ||||
| 13467 | 1120 | 946 | my $type = ref $obj; | ||||
| 13468 | 1120 | 1330 | my $network = | ||||
| 13469 | ($type eq 'Network') | ||||||
| 13470 | ? $obj | ||||||
| 13471 | : $obj->{network}; | ||||||
| 13472 | 1120 | 2028 | my $nat_hash = $network->{nat} or next; | ||||
| 13473 | 77 | 112 | my $other = $where eq 'src' ? $rule->{dst} : $rule->{src}; | ||||
| 13474 | 77 | 70 | my $otype = ref $other; | ||||
| 13475 | 77 | 111 | my $nat_domain = ($otype eq 'Network') | ||||
| 13476 | ? $other->{nat_domain} # Is undef for aggregate. | ||||||
| 13477 | : $other->{network}->{nat_domain}; | ||||||
| 13478 | 77 | 55 | my $hidden_seen; | ||||
| 13479 | my $dynamic_seen; | ||||||
| 13480 | 0 | 0 | my $static_seen; | ||||
| 13481 | |||||||
| 13482 | # Find $nat_tag which is effective at $other. | ||||||
| 13483 | # - single: $other is host or network, $nat_domain is known. | ||||||
| 13484 | # - multiple: $other is aggregate. | ||||||
| 13485 | # Check all NAT domains at border of corresponding zone. | ||||||
| 13486 | 77 2 | 131 3 | for my $no_nat_set ( $nat_domain | ||||
| 13487 | ? ($nat_domain->{no_nat_set}) | ||||||
| 13488 | 1 | 2 | : map({ $_->{no_nat_set} } | ||||
| 13489 | @{ $other->{zone}->{interfaces} })) | ||||||
| 13490 | { | ||||||
| 13491 | 78 | 66 | my $nat_found; | ||||
| 13492 | 78 | 126 | for my $nat_tag (sort keys %$nat_hash) { | ||||
| 13493 | 78 | 135 | next if $no_nat_set->{$nat_tag}; | ||||
| 13494 | 64 | 54 | $nat_found = 1; | ||||
| 13495 | 64 | 62 | my $nat_network = $nat_hash->{$nat_tag}; | ||||
| 13496 | |||||||
| 13497 | # Network is hidden by NAT. | ||||||
| 13498 | 64 | 104 | if ($nat_network->{hidden}) { | ||||
| 13499 | 3 | 13 | $hidden_seen++ or | ||||
| 13500 | err_msg("$obj->{name} is hidden by nat:$nat_tag", | ||||||
| 13501 | " in rule\n ", | ||||||
| 13502 | print_rule $rule); | ||||||
| 13503 | 3 | 6 | next; | ||||
| 13504 | } | ||||||
| 13505 | 61 | 91 | if (!$nat_network->{dynamic}) { | ||||
| 13506 | 13 | 9 | $static_seen = 1; | ||||
| 13507 | 13 | 20 | next; | ||||
| 13508 | } | ||||||
| 13509 | |||||||
| 13510 | # Network has dynamic NAT. | ||||||
| 13511 | 48 | 66 | $dynamic_seen and next; | ||||
| 13512 | 48 | 159 | $type eq 'Subnet' or $type eq 'Interface' or next; | ||||
| 13513 | |||||||
| 13514 | # Host / interface doesn't have static NAT. | ||||||
| 13515 | 24 | 57 | $obj->{nat}->{$nat_tag} and next; | ||||
| 13516 | |||||||
| 13517 | # Check error condition: Dynamic NAT address is | ||||||
| 13518 | # used in ACL at managed router at the border of | ||||||
| 13519 | # zone of $obj. | ||||||
| 13520 | # $intf could have value 'undef' if $obj is interface of | ||||||
| 13521 | # current router and destination of rule. | ||||||
| 13522 | my $check = sub { | ||||||
| 13523 | 10 | 10 | my ($rule, $in_intf, $out_intf) = @_; | ||||
| 13524 | 10 | 11 | my $no_nat_set = $in_intf->{no_nat_set}; | ||||
| 13525 | 10 | 11 | my $nat_network = | ||||
| 13526 | get_nat_network($network, $no_nat_set); | ||||||
| 13527 | 10 | 12 | my $nat_tag = $nat_network->{dynamic}; | ||||
| 13528 | 10 | 15 | return if not $nat_tag; | ||||
| 13529 | 7 | 13 | return if $obj->{nat}->{$nat_tag}; | ||||
| 13530 | 7 | 10 | my $intf = $where eq 'src' ? $in_intf : $out_intf; | ||||
| 13531 | 7 | 19 | if (!$intf || | ||||
| 13532 | zone_eq($network->{zone}, $intf->{zone})) | ||||||
| 13533 | { | ||||||
| 13534 | 5 | 19 | err_msg "$obj->{name} needs static translation", | ||||
| 13535 | " for nat:$nat_tag to be valid in rule\n ", | ||||||
| 13536 | print_rule $rule; | ||||||
| 13537 | } | ||||||
| 13538 | 7 | 28 | }; | ||||
| 13539 | 7 | 8 | path_walk($rule, $check); | ||||
| 13540 | |||||||
| 13541 | 7 | 8 | $dynamic_nat = | ||||
| 13542 | $dynamic_nat | ||||||
| 13543 | ? "$dynamic_nat,$where" | ||||||
| 13544 | : $where; | ||||||
| 13545 | |||||||
| 13546 | # debug("dynamic_nat: $where at ", print_rule $rule); | ||||||
| 13547 | 7 | 34 | $dynamic_seen = 1; | ||||
| 13548 | } | ||||||
| 13549 | 78 | 166 | $nat_found or $static_seen = 1; | ||||
| 13550 | } | ||||||
| 13551 | |||||||
| 13552 | 77 | 109 | $hidden_seen and next; | ||||
| 13553 | |||||||
| 13554 | # Check error conditition: | ||||||
| 13555 | # Find sub-path where dynamic / hidden NAT is enabled, | ||||||
| 13556 | # i.e. dynamic / hidden NAT is enabled first and disabled later. | ||||||
| 13557 | |||||||
| 13558 | # Find dynamic and hidden NAT definitions of $obj. | ||||||
| 13559 | # Key: NAT tag, | ||||||
| 13560 | # value: boolean, true=hidden, false=dynamic | ||||||
| 13561 | 74 | 61 | my $dyn_nat_hash; | ||||
| 13562 | 74 | 108 | for my $nat_tag (keys %$nat_hash) { | ||||
| 13563 | 74 | 77 | my $nat_network = $nat_hash->{$nat_tag}; | ||||
| 13564 | 74 | 118 | $nat_network->{dynamic} or next; | ||||
| 13565 | 60 | 118 | $dyn_nat_hash->{$nat_tag} = $nat_network->{hidden}; | ||||
| 13566 | } | ||||||
| 13567 | 74 | 133 | $dyn_nat_hash or next; | ||||
| 13568 | |||||||
| 13569 | 54 | 115 | my $from_store = $obj2path{$obj} || get_path $obj; | ||||
| 13570 | 54 | 100 | my $to_store = $obj2path{$other} || get_path $other; | ||||
| 13571 | 54 | 191 | my $active_nat_at = | ||||
| 13572 | $cache{$from_store}->{$to_store} || | ||||||
| 13573 | $cache{$to_store}->{$from_store}; | ||||||
| 13574 | |||||||
| 13575 | 54 | 75 | if (!$active_nat_at) { | ||||
| 13576 | 35 | 80 | $cache{$from_store}->{$to_store} = | ||||
| 13577 | $active_nat_at = $rule->{active_nat_at} = {}; | ||||||
| 13578 | 35 | 61 | path_walk($rule, $check_dyn_nat); | ||||
| 13579 | 35 | 51 | delete $rule->{active_nat_at}; | ||||
| 13580 | } | ||||||
| 13581 | |||||||
| 13582 | 54 | 121 | for my $nat_tag (sort keys %$dyn_nat_hash) { | ||||
| 13583 | 60 | 127 | my $interfaces = $active_nat_at->{$nat_tag} or next; | ||||
| 13584 | 53 | 46 | my $is_hidden = $dyn_nat_hash->{$nat_tag}; | ||||
| 13585 | 53 | 251 | ($is_hidden || $static_seen) or next; | ||||
| 13586 | 12 | 24 | my $names = | ||||
| 13587 | 5 | 10 | join("\n - ", map({ $_->{name} } sort(by_name @$interfaces))); | ||||
| 13588 | 5 | 10 | my $type = $is_hidden ? 'hidden' : 'dynamic'; | ||||
| 13589 | 5 | 17 | err_msg("Must not apply $type NAT '$nat_tag' on path\n", | ||||
| 13590 | " of", $where eq 'dst' ? ' reversed' : '', " rule\n", | ||||||
| 13591 | " ", print_rule($rule), "\n", | ||||||
| 13592 | " NAT '$nat_tag' is active at\n", | ||||||
| 13593 | " - $names\n", | ||||||
| 13594 | " Add pathrestriction", | ||||||
| 13595 | " to exclude this path"); | ||||||
| 13596 | } | ||||||
| 13597 | } | ||||||
| 13598 | 560 | 966 | $rule->{dynamic_nat} = $dynamic_nat if $dynamic_nat; | ||||
| 13599 | } | ||||||
| 13600 | 226 | 1104 | return; | ||||
| 13601 | } | ||||||
| 13602 | |||||||
| 13603 | ############################################################################## | ||||||
| 13604 | # Optimize expanded rules by deleting identical rules and | ||||||
| 13605 | # rules which are overlapped by a more general rule | ||||||
| 13606 | ############################################################################## | ||||||
| 13607 | |||||||
| 13608 | sub optimize_rules { | ||||||
| 13609 | 264 | 0 | 264 | my ($cmp_hash, $chg_hash) = @_; | |||
| 13610 | 264 | 652 | while (my ($stateless, $chg_hash) = each %$chg_hash) { | ||||
| 13611 | 230 | 183 | while (1) { | ||||
| 13612 | 268 | 455 | if (my $cmp_hash = $cmp_hash->{$stateless}) { | ||||
| 13613 | 230 | 532 | while (my ($deny, $chg_hash) = each %$chg_hash) { | ||||
| 13614 | 230 | 175 | while (1) { | ||||
| 13615 | 460 | 751 | if (my $cmp_hash = $cmp_hash->{$deny}) { | ||||
| 13616 | 230 | 520 | while (my ($src_range_ref, $chg_hash) = each %$chg_hash) { | ||||
| 13617 | 256 | 236 | my $src_range = $ref2prt{$src_range_ref}; | ||||
| 13618 | 256 | 195 | while (1) { | ||||
| 13619 | 322 | 608 | if (my $cmp_hash = $cmp_hash->{$src_range}) { | ||||
| 13620 | 280 | 570 | while (my ($src_ref, $chg_hash) = each %$chg_hash) { | ||||
| 13621 | 475 | 428 | my $src = $ref2obj{$src_ref}; | ||||
| 13622 | 475 | 680 | while (1) { | ||||
| 13623 | 785 | 1391 | if (my $cmp_hash = $cmp_hash->{$src}) { | ||||
| 13624 | 462 | 889 | while (my ($dst_ref, $chg_hash) = each %$chg_hash) { | ||||
| 13625 | 591 | 854 | my $dst = $ref2obj{$dst_ref}; | ||||
| 13626 | 591 | 449 | while (1) { | ||||
| 13627 | 966 | 1683 | if (my $cmp_hash = $cmp_hash->{$dst}) { | ||||
| 13628 | 595 | 1165 | for my $chg_rule (values %$chg_hash) { | ||||
| 13629 | |||||||
| 13630 | # Even if $change_rule already is marked as deleted, | ||||||
| 13631 | # don't stop here, but go on and find all redundant | ||||||
| 13632 | # pairs of ($change_rule, $cmp_rule). | ||||||
| 13633 | # This is needed, because some instances of $cmp_rule | ||||||
| 13634 | # may have an {overlaps} attribute, which prevents | ||||||
| 13635 | # a warning message to be printed. | ||||||
| 13636 | 627 | 562 | my $prt = $chg_rule->{prt}; | ||||
| 13637 | 627 | 1510 | my $chg_log = $chg_rule->{log} || ''; | ||||
| 13638 | 627 | 454 | while (1) { | ||||
| 13639 | 1703 | 2743 | if (my $cmp_rule = $cmp_hash->{$prt}) { | ||||
| 13640 | 556 | 1246 | my $cmp_log = $cmp_rule->{log} || ''; | ||||
| 13641 | 556 | 2294 | if ($cmp_rule ne $chg_rule && $cmp_log eq $chg_log) { | ||||
| 13642 | # debug("Del:", print_rule $chg_rule); | ||||||
| 13643 | # debug("Oth:", print_rule $cmp_rule); | ||||||
| 13644 | 32 | 34 | $chg_rule->{deleted} = $cmp_rule; | ||||
| 13645 | 32 | 107 | collect_redundant_rules($chg_rule, $cmp_rule); | ||||
| 13646 | 32 | 64 | last; | ||||
| 13647 | } | ||||||
| 13648 | } | ||||||
| 13649 | 1671 | 3011 | $prt = $prt->{up} or last; | ||||
| 13650 | } | ||||||
| 13651 | } | ||||||
| 13652 | } | ||||||
| 13653 | 966 | 2348 | $dst = $dst->{up} or last; | ||||
| 13654 | } | ||||||
| 13655 | } | ||||||
| 13656 | } | ||||||
| 13657 | 785 | 1767 | $src = $src->{up} or last; | ||||
| 13658 | } | ||||||
| 13659 | } | ||||||
| 13660 | } | ||||||
| 13661 | 322 | 826 | $src_range = $src_range->{up} or last; | ||||
| 13662 | } | ||||||
| 13663 | } | ||||||
| 13664 | } | ||||||
| 13665 | 460 | 886 | last if $deny; | ||||
| 13666 | 230 | 226 | $deny = 1; | ||||
| 13667 | } | ||||||
| 13668 | } | ||||||
| 13669 | } | ||||||
| 13670 | 268 | 646 | last if !$stateless; | ||||
| 13671 | 38 | 44 | $stateless = ''; | ||||
| 13672 | } | ||||||
| 13673 | } | ||||||
| 13674 | 264 | 264 | return; | ||||
| 13675 | } | ||||||
| 13676 | |||||||
| 13677 | sub optimize_and_warn_deleted { | ||||||
| 13678 | 226 | 0 | 631 | progress('Optimizing globally'); | |||
| 13679 | 226 | 330 | setup_ref2obj(); | ||||
| 13680 | 226 | 423 | optimize_rules(\%rule_tree, \%rule_tree); | ||||
| 13681 | 226 | 332 | print_rulecount(); | ||||
| 13682 | 226 | 313 | show_deleted_rules2(); | ||||
| 13683 | 226 | 323 | warn_unused_overlaps(); | ||||
| 13684 | 226 | 184 | return; | ||||
| 13685 | } | ||||||
| 13686 | |||||||
| 13687 | ######################################################################## | ||||||
| 13688 | # Prepare NAT commands | ||||||
| 13689 | ######################################################################## | ||||||
| 13690 | |||||||
| 13691 | # Collect devices which need NAT commands. | ||||||
| 13692 | sub collect_nat_path { | ||||||
| 13693 | 387 | 0 | 364 | my ($rule, $in_intf, $out_intf) = @_; | |||
| 13694 | |||||||
| 13695 | # No NAT needed for directly attached interface. | ||||||
| 13696 | 387 | 564 | return unless $out_intf; | ||||
| 13697 | |||||||
| 13698 | # No NAT needed for traffic originating from the device itself. | ||||||
| 13699 | 324 | 453 | return unless $in_intf; | ||||
| 13700 | |||||||
| 13701 | 293 | 276 | my $router = $out_intf->{router}; | ||||
| 13702 | 293 | 456 | return unless $router->{managed}; | ||||
| 13703 | 279 | 247 | my $model = $router->{model}; | ||||
| 13704 | 279 | 523 | return unless $model->{has_interface_level}; | ||||
| 13705 | |||||||
| 13706 | 122 122 | 103 271 | push @{ $rule->{nat_path} }, [ $in_intf, $out_intf ]; | ||||
| 13707 | 122 | 160 | return; | ||||
| 13708 | } | ||||||
| 13709 | |||||||
| 13710 | # Distribute networks needing NAT commands to device. | ||||||
| 13711 | sub distribute_nat_to_device { | ||||||
| 13712 | 122 | 0 | 109 | my ($pair, $src_net, $dst_net) = @_; | |||
| 13713 | 122 | 129 | my ($in_intf, $out_intf) = @$pair; | ||||
| 13714 | 122 | 112 | my $router = $out_intf->{router}; | ||||
| 13715 | 122 | 115 | my $model = $router->{model}; | ||||
| 13716 | |||||||
| 13717 | # We need in_hw and out_hw for | ||||||
| 13718 | # - attaching attribute src_nat and | ||||||
| 13719 | # - getting the NAT tag. | ||||||
| 13720 | 122 | 107 | my $in_hw = $in_intf->{hardware}; | ||||
| 13721 | 122 | 103 | my $out_hw = $out_intf->{hardware}; | ||||
| 13722 | |||||||
| 13723 | 122 | 130 | my $identity_nat = $model->{need_identity_nat}; | ||||
| 13724 | 122 | 281 | if ($identity_nat) { | ||||
| 13725 | |||||||
| 13726 | # Static dst NAT is equivalent to reversed src NAT. | ||||||
| 13727 | 1 | 1 | for my $dst (@$dst_net) { | ||||
| 13728 | 1 | 4 | $out_hw->{src_nat}->{$in_hw}->{$dst} = $dst; | ||||
| 13729 | } | ||||||
| 13730 | 1 | 3 | if ($in_hw->{level} > $out_hw->{level}) { | ||||
| 13731 | 0 | 0 | $in_hw->{need_nat_0} = 1; | ||||
| 13732 | } | ||||||
| 13733 | } | ||||||
| 13734 | |||||||
| 13735 | # Not identity NAT, handle real dst NAT. | ||||||
| 13736 | elsif (my $nat_tags = $in_hw->{bind_nat}) { | ||||||
| 13737 | 11 | 13 | for my $dst (@$dst_net) { | ||||
| 13738 | 11 | 16 | my $nat_info = $dst->{nat} or next; | ||||
| 13739 | 11 11 | 19 25 | grep({ $nat_info->{$_} } @$nat_tags) or next; | ||||
| 13740 | |||||||
| 13741 | # Store reversed dst NAT for real translation. | ||||||
| 13742 | 11 | 39 | $out_hw->{src_nat}->{$in_hw}->{$dst} = $dst; | ||||
| 13743 | } | ||||||
| 13744 | } | ||||||
| 13745 | |||||||
| 13746 | # Handle real src NAT. | ||||||
| 13747 | # Remember: | ||||||
| 13748 | # NAT tag for network located behind in_hw is attached to out_hw. | ||||||
| 13749 | 122 | 1393 | my $nat_tags = $out_hw->{bind_nat} or return; | ||||
| 13750 | 14 | 15 | for my $src (@$src_net) { | ||||
| 13751 | 17 | 36 | my $nat_info = $src->{nat} or next; | ||||
| 13752 | |||||||
| 13753 | # We can be sure to get a single result. | ||||||
| 13754 | # Binding for different NAT of a single network has been | ||||||
| 13755 | # rejected in distribute_nat_info. | ||||||
| 13756 | 11 11 | 13 42 | my ($nat_net) = map({ $nat_info->{$_} || () } @$nat_tags) or next; | ||||
| 13757 | |||||||
| 13758 | # Store src NAT for real translation. | ||||||
| 13759 | 11 | 28 | $in_hw->{src_nat}->{$out_hw}->{$src} = $src; | ||||
| 13760 | |||||||
| 13761 | 11 | 29 | if ($identity_nat) { | ||||
| 13762 | |||||||
| 13763 | # Check if there is a dynamic NAT of src address from lower | ||||||
| 13764 | # to higher security level. We need this info to decide, | ||||||
| 13765 | # if static commands with "identity mapping" and a "nat 0" command | ||||||
| 13766 | # need to be generated. | ||||||
| 13767 | 0 | 0 | if ($nat_net->{dynamic} and $in_hw->{level} < $out_hw->{level}) { | ||||
| 13768 | 0 | 0 | $in_hw->{need_identity_nat} = 1; | ||||
| 13769 | 0 | 0 | $in_hw->{need_nat_0} = 1; | ||||
| 13770 | } | ||||||
| 13771 | } | ||||||
| 13772 | } | ||||||
| 13773 | 14 | 44 | return; | ||||
| 13774 | } | ||||||
| 13775 | |||||||
| 13776 | sub get_zone3 { | ||||||
| 13777 | 480 | 0 | 403 | my ($obj) = @_; | |||
| 13778 | 480 | 458 | my $type = ref $obj; | ||||
| 13779 | 480 | 772 | if ($type eq 'Network') { | ||||
| 13780 | 320 | 736 | return $obj->{zone}; | ||||
| 13781 | } | ||||||
| 13782 | elsif ($type eq 'Subnet') { | ||||||
| 13783 | 44 | 114 | return $obj->{network}->{zone}; | ||||
| 13784 | } | ||||||
| 13785 | elsif ($type eq 'Interface') { | ||||||
| 13786 | 116 | 114 | my $router = $obj->{router}; | ||||
| 13787 | 116 | 283 | if ($router->{managed} or $router->{semi_managed}) { | ||||
| 13788 | 64 | 145 | return $obj; | ||||
| 13789 | } | ||||||
| 13790 | else { | ||||||
| 13791 | 52 | 123 | return $obj->{network}->{zone}; | ||||
| 13792 | } | ||||||
| 13793 | } | ||||||
| 13794 | else { | ||||||
| 13795 | 0 | 0 | internal_err(); | ||||
| 13796 | } | ||||||
| 13797 | } | ||||||
| 13798 | |||||||
| 13799 | sub get_networks { | ||||||
| 13800 | 217 | 0 | 192 | my ($obj) = @_; | |||
| 13801 | 217 | 208 | my $type = ref $obj; | ||||
| 13802 | 217 | 445 | if ($type eq 'Network') { | ||||
| 13803 | 132 | 191 | if ($obj->{is_aggregate}) { | ||||
| 13804 | 17 | 40 | return $obj->{networks}; | ||||
| 13805 | } | ||||||
| 13806 | else { | ||||||
| 13807 | 115 | 299 | return [ $obj ]; | ||||
| 13808 | } | ||||||
| 13809 | } | ||||||
| 13810 | elsif ($type eq 'Subnet' or $type eq 'Interface') { | ||||||
| 13811 | 85 | 237 | return [ $obj->{network} ]; | ||||
| 13812 | } | ||||||
| 13813 | else { | ||||||
| 13814 | 0 | 0 | internal_err("unexpected $obj->{name}"); | ||||
| 13815 | } | ||||||
| 13816 | } | ||||||
| 13817 | |||||||
| 13818 | sub prepare_nat_commands { | ||||||
| 13819 | 226 | 0 | 274 | return if fast_mode(); | |||
| 13820 | 155 | 221 | progress('Preparing NAT commands'); | ||||
| 13821 | |||||||
| 13822 | # Caching for performance. | ||||||
| 13823 | 155 | 125 | my %obj2zone; | ||||
| 13824 | my %obj2networks; | ||||||
| 13825 | |||||||
| 13826 | # Traverse the topology once for each pair of | ||||||
| 13827 | # src-(zone/router), dst-(zone/router) | ||||||
| 13828 | 0 | 0 | my %zone2zone2info; | ||||
| 13829 | 155 155 155 | 136 184 223 | for my $rule (@{ $expanded_rules{permit} }, @{ $expanded_rules{supernet} }) | ||||
| 13830 | { | ||||||
| 13831 | next | ||||||
| 13832 | 414 | 661 | if $rule->{deleted} | ||||
| 13833 | and | ||||||
| 13834 | (not $rule->{managed_intf} or $rule->{deleted}->{managed_intf}); | ||||||
| 13835 | 409 409 | 335 486 | my ($src, $dst) = @{$rule}{qw(src dst)}; | ||||
| 13836 | 409 | 997 | my $from = $obj2zone{$src} ||= get_zone3($src); | ||||
| 13837 | 409 | 907 | my $to = $obj2zone{$dst} ||= get_zone3($dst); | ||||
| 13838 | 409 | 700 | my $info = $zone2zone2info{$from}->{$to}; | ||||
| 13839 | 409 | 569 | if (!$info) { | ||||
| 13840 | 244 | 435 | path_walk($rule, \&collect_nat_path, 'Router'); | ||||
| 13841 | 244 | 434 | $info->{nat_path} = delete $rule->{nat_path}; | ||||
| 13842 | 244 | 493 | $zone2zone2info{$from}->{$to} = $info; | ||||
| 13843 | } | ||||||
| 13844 | |||||||
| 13845 | # Collect networks only if path has some NAT device. | ||||||
| 13846 | 409 | 808 | if ($info->{nat_path}) { | ||||
| 13847 | 177 | 459 | my $src_networks = $obj2networks{$src} ||= get_networks($src); | ||||
| 13848 | 177 177 | 183 339 | @{$info->{src_net}}{@$src_networks} = @$src_networks; | ||||
| 13849 | 177 | 418 | my $dst_networks = $obj2networks{$dst} ||= get_networks($dst); | ||||
| 13850 | 177 177 | 161 524 | @{$info->{dst_net}}{@$dst_networks} = @$dst_networks; | ||||
| 13851 | } | ||||||
| 13852 | } | ||||||
| 13853 | 155 | 269 | for my $hash (values %zone2zone2info) { | ||||
| 13854 | 196 | 307 | for my $info (values %$hash) { | ||||
| 13855 | 244 | 529 | my $nat_path = $info->{nat_path} or next; | ||||
| 13856 | 99 99 | 87 186 | my $src_net = [ values %{ $info->{src_net} } ]; | ||||
| 13857 | 99 99 | 93 166 | my $dst_net = [ values %{ $info->{dst_net} } ]; | ||||
| 13858 | 99 | 133 | for my $pair (@$nat_path) { | ||||
| 13859 | 122 | 175 | distribute_nat_to_device($pair, $src_net, $dst_net); | ||||
| 13860 | } | ||||||
| 13861 | } | ||||||
| 13862 | } | ||||||
| 13863 | 155 | 568 | return; | ||||
| 13864 | } | ||||||
| 13865 | |||||||
| 13866 | ######################################################################## | ||||||
| 13867 | # Routing | ||||||
| 13868 | ######################################################################## | ||||||
| 13869 | |||||||
| 13870 | # Get networks for routing. | ||||||
| 13871 | # Add largest supernet inside the zone, if available. | ||||||
| 13872 | # This is needed, because we use the supernet in | ||||||
| 13873 | # secondary optimization too. | ||||||
| 13874 | # Moreover this reduces the number of routing entries. | ||||||
| 13875 | # It isn't sufficient to solely use the supernet because network and supernet | ||||||
| 13876 | # can have different next hops at end of path. | ||||||
| 13877 | # For an aggregate, take all matching networks inside the zone. | ||||||
| 13878 | # These are supernets by design. | ||||||
| 13879 | |||||||
| 13880 | sub get_route_networks { | ||||||
| 13881 | 927 | 0 | 731 | my ($obj) = @_; | |||
| 13882 | 927 | 818 | my $type = ref $obj; | ||||
| 13883 | 927 | 1644 | if ($type eq 'Network') { | ||||
| 13884 | 640 | 1103 | if ($obj->{is_aggregate}) { | ||||
| 13885 | 82 82 | 63 158 | return @{ $obj->{networks} }; | ||||
| 13886 | } | ||||||
| 13887 | elsif (my $max = $obj->{max_routing_net}) { | ||||||
| 13888 | 11 | 23 | return ($max, $obj); | ||||
| 13889 | } | ||||||
| 13890 | else { | ||||||
| 13891 | 547 | 754 | return $obj; | ||||
| 13892 | } | ||||||
| 13893 | } | ||||||
| 13894 | elsif ($type eq 'Subnet' or $type eq 'Interface') { | ||||||
| 13895 | 287 | 270 | my $net = $obj->{network}; | ||||
| 13896 | 287 | 379 | if (my $max = $net->{max_routing_net}) { | ||||
| 13897 | 28 | 56 | return ($max, $net); | ||||
| 13898 | } | ||||||
| 13899 | else { | ||||||
| 13900 | 259 | 402 | return $net; | ||||
| 13901 | } | ||||||
| 13902 | } | ||||||
| 13903 | else { | ||||||
| 13904 | 0 | 0 | internal_err("unexpected $obj->{name}"); | ||||
| 13905 | } | ||||||
| 13906 | } | ||||||
| 13907 | |||||||
| 13908 | # Set up data structure to find routing info inside a security zone. | ||||||
| 13909 | # Some definitions: | ||||||
| 13910 | # - Border interfaces are directly attached to the security zone. | ||||||
| 13911 | # - Border networks are located inside the security zone and are attached | ||||||
| 13912 | # to border interfaces. | ||||||
| 13913 | # - All interfaces of border networks, which are not border interfaces, | ||||||
| 13914 | # are called hop interfaces, because they are used as next hop from | ||||||
| 13915 | # border interfaces. | ||||||
| 13916 | # - A cluster is a maximal set of connected networks of the security zone, | ||||||
| 13917 | # which is surrounded by hop interfaces. A cluster can be empty. | ||||||
| 13918 | # For each border interface I and each network N inside the security zone | ||||||
| 13919 | # we need to find the hop interface H via which N is reached from I. | ||||||
| 13920 | # This is stored in an attribute {route_in_zone} of I. | ||||||
| 13921 | sub set_routes_in_zone { | ||||||
| 13922 | 658 | 0 | 561 | my ($zone) = @_; | |||
| 13923 | |||||||
| 13924 | # Mark border networks and hop interfaces. | ||||||
| 13925 | 658 | 452 | my %border_networks; | ||||
| 13926 | my %hop_interfaces; | ||||||
| 13927 | 658 658 | 502 811 | for my $in_interface (@{ $zone->{interfaces} }) { | ||||
| 13928 | 887 | 1276 | next if $in_interface->{main_interface}; | ||||
| 13929 | 845 | 730 | my $network = $in_interface->{network}; | ||||
| 13930 | 845 | 1949 | next if $border_networks{$network}; | ||||
| 13931 | 670 | 886 | $border_networks{$network} = $network; | ||||
| 13932 | 670 670 | 496 766 | for my $out_interface (@{ $network->{interfaces} }) { | ||||
| 13933 | 1006 | 2248 | next if $out_interface->{zone}; | ||||
| 13934 | 119 | 183 | next if $out_interface->{main_interface}; | ||||
| 13935 | 117 | 242 | $hop_interfaces{$out_interface} = $out_interface; | ||||
| 13936 | } | ||||||
| 13937 | } | ||||||
| 13938 | 658 | 1602 | return if not keys %hop_interfaces; | ||||
| 13939 | 93 | 75 | my %hop2cluster; | ||||
| 13940 | my %cluster2borders; | ||||||
| 13941 | 0 | 0 | my $set_cluster; | ||||
| 13942 | $set_cluster = sub { | ||||||
| 13943 | 131 | 129 | my ($router, $in_intf, $cluster) = @_; | ||||
| 13944 | 131 | 218 | return if $router->{active_path}; | ||||
| 13945 | 124 | 163 | local $router->{active_path} = 1; | ||||
| 13946 | 124 124 | 96 170 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 13947 | 307 | 449 | next if $interface->{main_interface}; | ||||
| 13948 | 295 | 517 | if ($hop_interfaces{$interface}) { | ||||
| 13949 | 117 | 177 | $hop2cluster{$interface} = $cluster; | ||||
| 13950 | 117 | 111 | my $network = $interface->{network}; | ||||
| 13951 | 117 | 246 | $cluster2borders{$cluster}->{$network} = $network; | ||||
| 13952 | 117 | 248 | next; | ||||
| 13953 | } | ||||||
| 13954 | 178 | 384 | next if $interface eq $in_intf; | ||||
| 13955 | 150 | 138 | my $network = $interface->{network}; | ||||
| 13956 | 150 | 242 | next if $cluster->{$network}; | ||||
| 13957 | 143 | 191 | $cluster->{$network} = $network; | ||||
| 13958 | 143 143 | 113 175 | for my $out_intf (@{ $network->{interfaces} }) { | ||||
| 13959 | 188 | 524 | next if $out_intf eq $interface; | ||||
| 13960 | 45 | 71 | next if $out_intf->{main_interface}; | ||||
| 13961 | 35 | 96 | $set_cluster->($out_intf->{router}, $out_intf, $cluster); | ||||
| 13962 | } | ||||||
| 13963 | } | ||||||
| 13964 | 93 | 328 | }; | ||||
| 13965 | 93 | 140 | for my $interface (values %hop_interfaces) { | ||||
| 13966 | 117 | 234 | next if $hop2cluster{$interface}; | ||||
| 13967 | 96 | 98 | my $cluster = {}; | ||||
| 13968 | 96 | 159 | $set_cluster->($interface->{router}, $interface, $cluster); | ||||
| 13969 | |||||||
| 13970 | # debug("Cluster: $interface->{name} ", | ||||||
| 13971 | # join ',', map {$_->{name}} values %$cluster); | ||||||
| 13972 | } | ||||||
| 13973 | |||||||
| 13974 | # Find all networks located behind a hop interface. | ||||||
| 13975 | 93 | 90 | my %hop2networks; | ||||
| 13976 | my $set_networks_behind; | ||||||
| 13977 | $set_networks_behind = sub { | ||||||
| 13978 | 124 | 130 | my ($hop, $in_border) = @_; | ||||
| 13979 | 124 | 222 | return if $hop2networks{$hop}; | ||||
| 13980 | 117 | 149 | my $cluster = $hop2cluster{$hop}; | ||||
| 13981 | |||||||
| 13982 | # Add networks of directly attached cluster to result. | ||||||
| 13983 | 117 | 198 | my @result = values %$cluster; | ||||
| 13984 | 117 | 185 | $hop2networks{$hop} = \@result; | ||||
| 13985 | |||||||
| 13986 | 117 117 | 106 231 | for my $border (values %{ $cluster2borders{$cluster} }) { | ||||
| 13987 | 155 | 384 | next if $border eq $in_border; | ||||
| 13988 | |||||||
| 13989 | # Add other border networks to result. | ||||||
| 13990 | 38 | 49 | push @result, $border; | ||||
| 13991 | 38 38 | 33 46 | for my $out_hop (@{ $border->{interfaces} }) { | ||||
| 13992 | 83 | 169 | next if not $hop_interfaces{$out_hop}; | ||||
| 13993 | 45 | 175 | next if $hop2cluster{$out_hop} eq $cluster; | ||||
| 13994 | 7 | 13 | $set_networks_behind->($out_hop, $border); | ||||
| 13995 | |||||||
| 13996 | # Add networks from clusters located behind | ||||||
| 13997 | # other border networks. | ||||||
| 13998 | 7 7 | 6 16 | push @result, @{ $hop2networks{$out_hop} }; | ||||
| 13999 | } | ||||||
| 14000 | } | ||||||
| 14001 | 117 | 177 | $hop2networks{$hop} = [ unique @result]; | ||||
| 14002 | # debug("Hop: $hop->{name} ", join ',', map {$_->{name}} @result); | ||||||
| 14003 | 93 | 321 | }; | ||||
| 14004 | 93 | 134 | for my $border (values %border_networks) { | ||||
| 14005 | 111 | 96 | my @border_intf; | ||||
| 14006 | my @hop_intf; | ||||||
| 14007 | 111 111 | 92 142 | for my $interface (@{ $border->{interfaces} }) { | ||||
| 14008 | 233 | 346 | next if $interface->{main_interface}; | ||||
| 14009 | 231 | 293 | if ($interface->{zone}) { | ||||
| 14010 | 114 | 149 | push @border_intf, $interface; | ||||
| 14011 | } | ||||||
| 14012 | else { | ||||||
| 14013 | 117 | 162 | push @hop_intf, $interface; | ||||
| 14014 | } | ||||||
| 14015 | } | ||||||
| 14016 | 111 | 124 | for my $hop (@hop_intf) { | ||||
| 14017 | 117 | 154 | $set_networks_behind->($hop, $border); | ||||
| 14018 | 117 | 147 | for my $interface (@border_intf) { | ||||
| 14019 | 120 120 | 99 197 | for my $network (@{ $hop2networks{$hop} }) { | ||||
| 14020 | |||||||
| 14021 | # $border will be found accidently, if clusters | ||||||
| 14022 | # form a loop inside zone. | ||||||
| 14023 | 205 | 369 | next if $network eq $border; | ||||
| 14024 | 201 201 | 156 710 | push @{ $interface->{route_in_zone}->{$network} }, $hop; | ||||
| 14025 | } | ||||||
| 14026 | } | ||||||
| 14027 | } | ||||||
| 14028 | } | ||||||
| 14029 | 93 | 212 | return; | ||||
| 14030 | } | ||||||
| 14031 | |||||||
| 14032 | # A security zone is entered at $in_intf and exited at $out_intf. | ||||||
| 14033 | # Find the hop H to reach $out_intf from $in_intf. | ||||||
| 14034 | # Add routing entries at $in_intf that $dst_networks are reachable via H. | ||||||
| 14035 | sub add_path_routes { | ||||||
| 14036 | 245 | 0 | 228 | my ($in_intf, $out_intf, $dst_networks) = @_; | |||
| 14037 | 245 | 439 | return if $in_intf->{routing}; | ||||
| 14038 | 149 | 153 | my $out_net = $out_intf->{network}; | ||||
| 14039 | 149 | 497 | my $hops = $in_intf->{route_in_zone}->{$out_net} || [$out_intf]; | ||||
| 14040 | 149 | 175 | for my $hop (@$hops) { | ||||
| 14041 | 151 | 253 | $in_intf->{hop}->{$hop} = $hop; | ||||
| 14042 | 151 | 155 | for my $network (@$dst_networks) { | ||||
| 14043 | |||||||
| 14044 | # debug("$in_intf->{name} -> $hop->{name}: $network->{name}"); | ||||||
| 14045 | 155 | 514 | $in_intf->{routes}->{$hop}->{$network} = $network; | ||||
| 14046 | } | ||||||
| 14047 | } | ||||||
| 14048 | 149 | 250 | return; | ||||
| 14049 | } | ||||||
| 14050 | |||||||
| 14051 | # A security zone is entered at $interface. | ||||||
| 14052 | # $dst_networks are located inside the security zone. | ||||||
| 14053 | # For each element N of $dst_networks find the next hop H to reach N. | ||||||
| 14054 | # Add routing entries at $interface that N is reachable via H. | ||||||
| 14055 | sub add_end_routes { | ||||||
| 14056 | 648 | 0 | 554 | my ($interface, $dst_networks) = @_; | |||
| 14057 | 648 | 1231 | return if $interface->{routing}; | ||||
| 14058 | 481 | 442 | my $intf_net = $interface->{network}; | ||||
| 14059 | 481 | 394 | my $route_in_zone = $interface->{route_in_zone}; | ||||
| 14060 | 481 | 471 | for my $network (@$dst_networks) { | ||||
| 14061 | 542 | 1273 | next if $network eq $intf_net; | ||||
| 14062 | 186 | 395 | my $hops = $route_in_zone->{$network} | ||||
| 14063 | or internal_err("Missing route for $network->{name}", | ||||||
| 14064 | " at $interface->{name}"); | ||||||
| 14065 | 186 | 172 | for my $hop (@$hops) { | ||||
| 14066 | 192 | 309 | $interface->{hop}->{$hop} = $hop; | ||||
| 14067 | |||||||
| 14068 | # debug("$interface->{name} -> $hop->{name}: $network->{name}"); | ||||||
| 14069 | 192 | 593 | $interface->{routes}->{$hop}->{$network} = $network; | ||||
| 14070 | } | ||||||
| 14071 | } | ||||||
| 14072 | 481 | 1006 | return; | ||||
| 14073 | } | ||||||
| 14074 | |||||||
| 14075 | # This function is called for each zone on the path from src to dst | ||||||
| 14076 | # of $rule. | ||||||
| 14077 | # If $in_intf and $out_intf are both defined, packets traverse this zone. | ||||||
| 14078 | # If $in_intf is not defined, the src is this zone. | ||||||
| 14079 | # If $out_intf is not defined, dst is this zone; | ||||||
| 14080 | sub get_route_path { | ||||||
| 14081 | 645 | 0 | 578 | my ($rule, $in_intf, $out_intf) = @_; | |||
| 14082 | |||||||
| 14083 | # debug("collect: $rule->{src}->{name} -> $rule->{dst}->{name}"); | ||||||
| 14084 | # my $info = ''; | ||||||
| 14085 | # $info .= $in_intf->{name} if $in_intf; | ||||||
| 14086 | # $info .= ' -> '; | ||||||
| 14087 | # $info .= $out_intf->{name} if $out_intf; | ||||||
| 14088 | # debug($info); | ||||||
| 14089 | |||||||
| 14090 | 645 | 1699 | if ($in_intf and $out_intf) { | ||||
| 14091 | 112 112 | 78 243 | push @{ $rule->{path} }, [ $in_intf, $out_intf ]; | ||||
| 14092 | } | ||||||
| 14093 | elsif (not $in_intf) { | ||||||
| 14094 | 266 266 | 206 490 | push @{ $rule->{path_entries} }, $out_intf; | ||||
| 14095 | } | ||||||
| 14096 | else { | ||||||
| 14097 | 267 267 | 206 466 | push @{ $rule->{path_exits} }, $in_intf; | ||||
| 14098 | } | ||||||
| 14099 | 645 | 728 | return; | ||||
| 14100 | } | ||||||
| 14101 | |||||||
| 14102 | sub check_and_convert_routes; | ||||||
| 14103 | |||||||
| 14104 | sub find_active_routes { | ||||||
| 14105 | 226 | 0 | 311 | progress('Finding routes'); | |||
| 14106 | 226 | 254 | for my $zone (@zones) { | ||||
| 14107 | 658 | 798 | set_routes_in_zone $zone; | ||||
| 14108 | } | ||||||
| 14109 | 226 | 208 | my %routing_tree; | ||||
| 14110 | 226 | 382 | my $pseudo_prt = { name => '--' }; | ||||
| 14111 | 226 226 226 | 205 268 311 | for my $rule (@{ $expanded_rules{permit} }, @{ $expanded_rules{supernet} }) | ||||
| 14112 | { | ||||||
| 14113 | 524 | 643 | my ($src, $dst) = ($rule->{src}, $rule->{dst}); | ||||
| 14114 | |||||||
| 14115 | # Ignore deleted rules. | ||||||
| 14116 | # Add the typical check for {managed_intf} | ||||||
| 14117 | # which covers the destination interface. | ||||||
| 14118 | # Because we handle both directions at once, | ||||||
| 14119 | # we would need an attribute {managed_intf} | ||||||
| 14120 | # for the source interface as well. But this attribute doesn't exist | ||||||
| 14121 | # and we add an equivalent check for source. | ||||||
| 14122 | 524 | 938 | if ( | ||||
| 14123 | $rule->{deleted} | ||||||
| 14124 | and (not $rule->{managed_intf} or $rule->{deleted}->{managed_intf}) | ||||||
| 14125 | and ( | ||||||
| 14126 | not(is_interface $src and ($src->{router}->{managed} or | ||||||
| 14127 | $src->{router}->{routing_only})) | ||||||
| 14128 | or (is_interface $rule->{deleted}->{src} | ||||||
| 14129 | and ($rule->{deleted}->{src}->{router}->{managed} or | ||||||
| 14130 | $rule->{deleted}->{src}->{router}->{routing_only})) | ||||||
| 14131 | ) | ||||||
| 14132 | ) | ||||||
| 14133 | { | ||||||
| 14134 | 20 | 26 | next; | ||||
| 14135 | } | ||||||
| 14136 | 504 | 626 | my $src_zone = get_zone2 $src; | ||||
| 14137 | 504 | 575 | my $dst_zone = get_zone2 $dst; | ||||
| 14138 | |||||||
| 14139 | # Source interface is located in security zone of destination or | ||||||
| 14140 | # destination interface is located in security zone of source. | ||||||
| 14141 | # path_walk will do nothing. | ||||||
| 14142 | 504 | 1025 | if ($src_zone eq $dst_zone) { | ||||
| 14143 | 98 | 105 | for my $from ($src, $dst) { | ||||
| 14144 | 196 | 325 | my $to = $from eq $src ? $dst : $src; | ||||
| 14145 | 196 | 220 | next if not is_interface($from); | ||||
| 14146 | 170 | 311 | next if not $from->{zone}; | ||||
| 14147 | 115 | 313 | $from = $from->{main_interface} || $from; | ||||
| 14148 | 115 | 143 | my @networks = get_route_networks($to); | ||||
| 14149 | 115 | 146 | add_end_routes($from, \@networks); | ||||
| 14150 | } | ||||||
| 14151 | 98 | 138 | next; | ||||
| 14152 | } | ||||||
| 14153 | 406 | 297 | my $pseudo_rule; | ||||
| 14154 | 406 | 1182 | if ($pseudo_rule = $routing_tree{$src_zone}->{$dst_zone}) { | ||||
| 14155 | } | ||||||
| 14156 | elsif ($pseudo_rule = $routing_tree{$dst_zone}->{$src_zone}) { | ||||||
| 14157 | 13 | 22 | ($src, $dst) = ($dst, $src); | ||||
| 14158 | 13 | 17 | ($src_zone, $dst_zone) = ($dst_zone, $src_zone); | ||||
| 14159 | } | ||||||
| 14160 | else { | ||||||
| 14161 | 246 | 491 | $pseudo_rule = { | ||||
| 14162 | src => $src_zone, | ||||||
| 14163 | dst => $dst_zone, | ||||||
| 14164 | prt => $pseudo_prt, | ||||||
| 14165 | }; | ||||||
| 14166 | 246 | 476 | $routing_tree{$src_zone}->{$dst_zone} = $pseudo_rule; | ||||
| 14167 | } | ||||||
| 14168 | 406 | 511 | my @src_networks = get_route_networks($src); | ||||
| 14169 | 406 | 449 | for my $network (@src_networks) { | ||||
| 14170 | 419 | 1005 | $pseudo_rule->{src_networks}->{$network} = $network; | ||||
| 14171 | } | ||||||
| 14172 | 406 | 495 | my @dst_networks = get_route_networks($dst); | ||||
| 14173 | 406 | 439 | for my $network (@dst_networks) { | ||||
| 14174 | 413 | 951 | $pseudo_rule->{dst_networks}->{$network} = $network; | ||||
| 14175 | } | ||||||
| 14176 | 406 | 522 | if (is_interface($src) && ($src->{router}->{managed} || | ||||
| 14177 | $src->{router}->{routing_only})) | ||||||
| 14178 | { | ||||||
| 14179 | 17 | 52 | $src = $src->{main_interface} || $src; | ||||
| 14180 | 17 | 32 | $pseudo_rule->{src_interfaces}->{$src} = $src; | ||||
| 14181 | 17 | 22 | for my $network (@dst_networks) { | ||||
| 14182 | 17 | 49 | $pseudo_rule->{src_intf2nets}->{$src}->{$network} = $network; | ||||
| 14183 | } | ||||||
| 14184 | } | ||||||
| 14185 | 406 | 496 | if (is_interface($dst) && ($dst->{router}->{managed} || | ||||
| 14186 | $dst->{router}->{routing_only})) | ||||||
| 14187 | { | ||||||
| 14188 | 37 | 141 | $dst = $dst->{main_interface} || $dst; | ||||
| 14189 | 37 | 73 | $pseudo_rule->{dst_interfaces}->{$dst} = $dst; | ||||
| 14190 | 37 | 43 | for my $network (@src_networks) { | ||||
| 14191 | 36 | 165 | $pseudo_rule->{dst_intf2nets}->{$dst}->{$network} = $network; | ||||
| 14192 | } | ||||||
| 14193 | } | ||||||
| 14194 | } | ||||||
| 14195 | 226 | 382 | for my $href (values %routing_tree) { | ||||
| 14196 | 426 | 745 | for my $pseudo_rule (values %$href) { | ||||
| 14197 | 246 | 410 | path_walk($pseudo_rule, \&get_route_path, 'Zone'); | ||||
| 14198 | 246 246 | 212 498 | my $src_networks = [ values %{ $pseudo_rule->{src_networks} } ]; | ||||
| 14199 | 246 246 | 218 423 | my $dst_networks = [ values %{ $pseudo_rule->{dst_networks} } ]; | ||||
| 14200 | 246 246 | 204 489 | my @src_interfaces = values %{ $pseudo_rule->{src_interfaces} }; | ||||
| 14201 | 246 246 | 195 372 | my @dst_interfaces = values %{ $pseudo_rule->{dst_interfaces} }; | ||||
| 14202 | 246 246 | 195 389 | for my $tuple (@{ $pseudo_rule->{path} }) { | ||||
| 14203 | 112 | 116 | my ($in_intf, $out_intf) = @$tuple; | ||||
| 14204 | 112 | 157 | add_path_routes($in_intf, $out_intf, $dst_networks); | ||||
| 14205 | 112 | 184 | add_path_routes($out_intf, $in_intf, $src_networks); | ||||
| 14206 | } | ||||||
| 14207 | 246 246 | 222 304 | for my $entry (@{ $pseudo_rule->{path_entries} }) { | ||||
| 14208 | 266 | 284 | for my $src_intf (@src_interfaces) { | ||||
| 14209 | 19 | 57 | next if $src_intf->{router} eq $entry->{router}; | ||||
| 14210 | 8 | 17 | if (my $redun_intf = $src_intf->{redundancy_interfaces}) { | ||||
| 14211 | 0 0 | 0 0 | if (grep { $_->{router} eq $entry->{router} } | ||||
| 14212 | @$redun_intf) | ||||||
| 14213 | { | ||||||
| 14214 | 0 | 0 | next; | ||||
| 14215 | } | ||||||
| 14216 | } | ||||||
| 14217 | 8 | 28 | my $intf_nets = [ | ||||
| 14218 | 8 | 6 | values %{ $pseudo_rule->{src_intf2nets}->{$src_intf} } | ||||
| 14219 | ]; | ||||||
| 14220 | 8 | 12 | add_path_routes($src_intf, $entry, $intf_nets); | ||||
| 14221 | } | ||||||
| 14222 | 266 | 366 | add_end_routes($entry, $src_networks); | ||||
| 14223 | } | ||||||
| 14224 | 246 246 | 225 339 | for my $exit (@{ $pseudo_rule->{path_exits} }) { | ||||
| 14225 | 267 | 278 | for my $dst_intf (@dst_interfaces) { | ||||
| 14226 | 45 | 130 | next if $dst_intf->{router} eq $exit->{router}; | ||||
| 14227 | 19 | 41 | if (my $redun_intf = $dst_intf->{redundancy_interfaces}) { | ||||
| 14228 | 6 12 | 7 31 | if (grep { $_->{router} eq $exit->{router} } | ||||
| 14229 | @$redun_intf) | ||||||
| 14230 | { | ||||||
| 14231 | 6 | 9 | next; | ||||
| 14232 | } | ||||||
| 14233 | } | ||||||
| 14234 | 13 | 35 | my $intf_nets = [ | ||||
| 14235 | 13 | 13 | values %{ $pseudo_rule->{dst_intf2nets}->{$dst_intf} } | ||||
| 14236 | ]; | ||||||
| 14237 | 13 | 23 | add_path_routes($dst_intf, $exit, $intf_nets); | ||||
| 14238 | } | ||||||
| 14239 | 267 | 303 | add_end_routes($exit, $dst_networks); | ||||
| 14240 | } | ||||||
| 14241 | } | ||||||
| 14242 | } | ||||||
| 14243 | 226 | 343 | check_and_convert_routes; | ||||
| 14244 | 226 | 954 | return; | ||||
| 14245 | } | ||||||
| 14246 | |||||||
| 14247 | # Parameters: | ||||||
| 14248 | # - a bridged interface without an IP address, not usable as hop. | ||||||
| 14249 | # - the network for which the hop was found. | ||||||
| 14250 | # Result: | ||||||
| 14251 | # - one or more layer 3 interfaces, usable as hop. | ||||||
| 14252 | # Non optimized version. | ||||||
| 14253 | # Doesn't matter as long we have only a few bridged networks | ||||||
| 14254 | # or don't use static routing at the border of bridged networks. | ||||||
| 14255 | sub fix_bridged_hops; | ||||||
| 14256 | |||||||
| 14257 | sub fix_bridged_hops { | ||||||
| 14258 | 2 | 0 | 2 | my ($hop, $network) = @_; | |||
| 14259 | 2 | 2 | my @result; | ||||
| 14260 | 2 | 3 | my $router = $hop->{router}; | ||||
| 14261 | 2 2 | 2 2 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 14262 | 6 | 12 | next if $interface eq $hop; | ||||
| 14263 | 4 | 17 | HOP: | ||||
| 14264 | 4 | 3 | for my $hop2 (values %{ $interface->{hop} }) { | ||||
| 14265 | 1 1 | 1 3 | for my $network2 (values %{ $interface->{routes}->{$hop2} }) { | ||||
| 14266 | 1 | 3 | if ($network eq $network2) { | ||||
| 14267 | 1 | 3 | if ($hop2->{ip} eq 'bridge') { | ||||
| 14268 | 0 | 0 | push @result, fix_bridged_hops($hop2, $network); | ||||
| 14269 | } | ||||||
| 14270 | else { | ||||||
| 14271 | 1 | 1 | push @result, $hop2; | ||||
| 14272 | } | ||||||
| 14273 | 1 | 3 | next HOP; | ||||
| 14274 | } | ||||||
| 14275 | } | ||||||
| 14276 | } | ||||||
| 14277 | } | ||||||
| 14278 | 2 | 7 | return @result; | ||||
| 14279 | } | ||||||
| 14280 | |||||||
| 14281 | sub check_and_convert_routes { | ||||||
| 14282 | 226 | 0 | 286 | progress('Checking for duplicate routes'); | |||
| 14283 | |||||||
| 14284 | # Fix routes to bridged interfaces without IP address. | ||||||
| 14285 | 226 | 268 | for my $router (@managed_routers, @routing_only_routers) { | ||||
| 14286 | 365 365 | 290 459 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 14287 | 862 | 1731 | next if not $interface->{network}->{bridged}; | ||||
| 14288 | 16 16 | 11 35 | for my $hop (values %{ $interface->{hop} }) { | ||||
| 14289 | 8 | 20 | next if $hop->{ip} ne 'bridged'; | ||||
| 14290 | 2 2 | 3 6 | for my $network (values %{ $interface->{routes}->{$hop} }) { | ||||
| 14291 | 2 | 3 | my @real_hop = fix_bridged_hops($hop, $network); | ||||
| 14292 | 2 | 4 | for my $rhop (@real_hop) { | ||||
| 14293 | 1 | 2 | $interface->{hop}->{$rhop} = $rhop; | ||||
| 14294 | 1 | 4 | $interface->{routes}->{$rhop}->{$network} = $network; | ||||
| 14295 | } | ||||||
| 14296 | } | ||||||
| 14297 | 2 | 4 | delete $interface->{hop}->{$hop}; | ||||
| 14298 | 2 | 7 | delete $interface->{routes}->{$hop}; | ||||
| 14299 | } | ||||||
| 14300 | } | ||||||
| 14301 | } | ||||||
| 14302 | |||||||
| 14303 | 226 | 282 | for my $router (@managed_routers, @routing_only_routers) { | ||||
| 14304 | |||||||
| 14305 | # Adjust routes through VPN tunnel to cleartext interface. | ||||||
| 14306 | 365 365 | 297 454 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 14307 | 862 | 1935 | next if not $interface->{ip} eq 'tunnel'; | ||||
| 14308 | 21 | 17 | my $tunnel_routes = $interface->{routes}; | ||||
| 14309 | 21 | 36 | $interface->{routes} = $interface->{hop} = {}; | ||||
| 14310 | 21 | 26 | my $real_intf = $interface->{real_interface}; | ||||
| 14311 | 21 | 31 | next if $real_intf->{routing}; | ||||
| 14312 | 21 | 17 | my $real_net = $real_intf->{network}; | ||||
| 14313 | 21 21 | 17 25 | for my $peer (@{ $interface->{peers} }) { | ||||
| 14314 | 21 | 20 | my $real_peer = $peer->{real_interface}; | ||||
| 14315 | 21 | 21 | my $peer_net = $real_peer->{network}; | ||||
| 14316 | |||||||
| 14317 | # Find hop to peer network and add tunnel networks to this hop. | ||||||
| 14318 | 21 | 17 | my @hops; | ||||
| 14319 | |||||||
| 14320 | # Peer network is directly connected. | ||||||
| 14321 | 21 | 1013 | if ($real_net eq $peer_net) { | ||||
| 14322 | 0 | 0 | if ($real_peer->{ip} !~ /^(?:short|negotiated)$/) { | ||||
| 14323 | 0 | 0 | push @hops, $real_peer; | ||||
| 14324 | } | ||||||
| 14325 | else { | ||||||
| 14326 | 0 | 0 | err_msg("$real_peer->{name} used to reach", | ||||
| 14327 | " software clients\n", | ||||||
| 14328 | " must not be directly connected to", | ||||||
| 14329 | " $real_intf->{name}\n", | ||||||
| 14330 | " Connect it to some network behind next hop"); | ||||||
| 14331 | 0 | 0 | next; | ||||
| 14332 | } | ||||||
| 14333 | } | ||||||
| 14334 | |||||||
| 14335 | # Peer network is located in directly connected zone. | ||||||
| 14336 | elsif ($real_net->{zone} eq $peer_net->{zone}) { | ||||||
| 14337 | 21 | 19 | my $route_in_zone = $real_intf->{route_in_zone}; | ||||
| 14338 | 21 | 39 | my $hops = $route_in_zone->{$peer_net} or | ||||
| 14339 | internal_err("Missing route for $peer_net->{name}", | ||||||
| 14340 | " at $real_intf->{name} "); | ||||||
| 14341 | 21 | 28 | push @hops, @$hops; | ||||
| 14342 | } | ||||||
| 14343 | |||||||
| 14344 | # Find path to peer network to determine available hops. | ||||||
| 14345 | else { | ||||||
| 14346 | 0 | 0 | my $pseudo_rule = { | ||||
| 14347 | src => $real_intf, | ||||||
| 14348 | dst => $peer_net, | ||||||
| 14349 | action => '--', | ||||||
| 14350 | prt => { name => '--' }, | ||||||
| 14351 | }; | ||||||
| 14352 | 0 | 0 | my @zone_hops; | ||||
| 14353 | my $walk = sub { | ||||||
| 14354 | 0 | 0 | my ($rule, $in_intf, $out_intf) = @_; | ||||
| 14355 | 0 | 0 | $in_intf or internal_err("No in_intf"); | ||||
| 14356 | 0 | 0 | $in_intf eq $real_intf or return; | ||||
| 14357 | 0 | 0 | $out_intf or internal_err("No out_intf"); | ||||
| 14358 | 0 | 0 | $out_intf->{network} or internal_err "No out net"; | ||||
| 14359 | 0 | 0 | push @zone_hops, $out_intf; | ||||
| 14360 | 0 | 0 | }; | ||||
| 14361 | 0 | 0 | path_walk($pseudo_rule, $walk, 'Zone'); | ||||
| 14362 | 0 | 0 | my $route_in_zone = $real_intf->{route_in_zone}; | ||||
| 14363 | 0 | 0 | for my $hop (@zone_hops) { | ||||
| 14364 | |||||||
| 14365 | 0 | 0 | my $hop_net = $hop->{network}; | ||||
| 14366 | 0 | 0 | if ($hop_net eq $real_net) { | ||||
| 14367 | 0 | 0 | push @hops, $hop; | ||||
| 14368 | } | ||||||
| 14369 | else { | ||||||
| 14370 | 0 | 0 | my $hops = $route_in_zone->{$hop_net} or | ||||
| 14371 | internal_err("Missing route for $hop_net->{name}", | ||||||
| 14372 | " at $real_intf->{name}"); | ||||||
| 14373 | 0 | 0 | push @hops, @$hops; | ||||
| 14374 | } | ||||||
| 14375 | } | ||||||
| 14376 | } | ||||||
| 14377 | |||||||
| 14378 | 21 | 17 | my $hop_routes; | ||||
| 14379 | 21 2 | 76 6 | if ( @hops > 1 | ||||
| 14380 | && equal(map({ $_->{redundancy_interfaces} || $_ } | ||||||
| 14381 | @hops)) | ||||||
| 14382 | || @hops == 1) | ||||||
| 14383 | { | ||||||
| 14384 | 20 | 18 | my $hop = shift @hops; | ||||
| 14385 | 20 | 51 | $hop_routes = $real_intf->{routes}->{$hop} ||= {}; | ||||
| 14386 | 20 | 32 | $real_intf->{hop}->{$hop} = $hop; | ||||
| 14387 | # debug "Use $hop->{name} as hop for $real_peer->{name}"; | ||||||
| 14388 | } | ||||||
| 14389 | else { | ||||||
| 14390 | |||||||
| 14391 | # This can only happen for vpn software clients. | ||||||
| 14392 | # For hardware clients the route is known | ||||||
| 14393 | # for the encrypted traffic which is allowed | ||||||
| 14394 | # by gen_tunnel_rules (even for negotiated interface). | ||||||
| 14395 | 1 | 2 | my $count = @hops; | ||||
| 14396 | 2 | 6 | my $names = join ('', | ||||
| 14397 | 1 | 1 | map({ "\n - $_->{name}" } | ||||
| 14398 | @hops)); | ||||||
| 14399 | 1 | 11 | err_msg( | ||||
| 14400 | "Can't determine next hop to reach $peer_net->{name}", | ||||||
| 14401 | " while moving routes\n", | ||||||
| 14402 | " of $interface->{name} to $real_intf->{name}.\n", | ||||||
| 14403 | " Exactly one route is needed,", | ||||||
| 14404 | " but $count candidates were found:", | ||||||
| 14405 | $names); | ||||||
| 14406 | } | ||||||
| 14407 | |||||||
| 14408 | # Use found hop to reach tunneled networks in $tunnel_routes. | ||||||
| 14409 | 21 | 39 | for my $tunnel_net_hash (values %$tunnel_routes) { | ||||
| 14410 | 17 | 26 | for my $tunnel_net (values %$tunnel_net_hash) { | ||||
| 14411 | 23 | 48 | $hop_routes->{$tunnel_net} = $tunnel_net; | ||||
| 14412 | } | ||||||
| 14413 | } | ||||||
| 14414 | |||||||
| 14415 | # Add route to reach peer interface. | ||||||
| 14416 | 21 | 44 | if ($peer_net ne $real_net) { | ||||
| 14417 | 21 | 83 | $hop_routes->{$peer_net} = $peer_net; | ||||
| 14418 | } | ||||||
| 14419 | } | ||||||
| 14420 | } | ||||||
| 14421 | |||||||
| 14422 | # Remember, via which local interface a network is reached. | ||||||
| 14423 | 365 | 320 | my %net2intf; | ||||
| 14424 | |||||||
| 14425 | 365 365 | 289 439 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 14426 | |||||||
| 14427 | # Remember, via which remote interface a network is reached. | ||||||
| 14428 | 862 | 640 | my %net2hop; | ||||
| 14429 | |||||||
| 14430 | # Remember, via which remote redundancy interfaces a network | ||||||
| 14431 | # is reached. We use this to check, if alle members of a group | ||||||
| 14432 | # of redundancy interfaces are used to reach the network. | ||||||
| 14433 | # Otherwise it would be wrong to route to the virtual interface. | ||||||
| 14434 | my %net2group; | ||||||
| 14435 | |||||||
| 14436 | 862 | 1874 | next if $interface->{loop} and $interface->{routing}; | ||||
| 14437 | 757 | 1096 | next if $interface->{ip} eq 'bridged'; | ||||
| 14438 | 743 743 | 574 1854 | for my $hop (sort by_name values %{ $interface->{hop} }) { | ||||
| 14439 | 150 150 | 143 418 | for my $network (sort by_name | ||||
| 14440 | values %{ $interface->{routes}->{$hop} }) | ||||||
| 14441 | { | ||||||
| 14442 | 226 | 382 | if (my $interface2 = $net2intf{$network}) { | ||||
| 14443 | 11 | 28 | if ($interface2 ne $interface) { | ||||
| 14444 | |||||||
| 14445 | # Network is reached via two different | ||||||
| 14446 | # local interfaces. Show warning if static | ||||||
| 14447 | # routing is enabled for both interfaces. | ||||||
| 14448 | 0 | 0 | if ( not $interface->{routing} | ||||
| 14449 | and not $interface2->{routing}) | ||||||
| 14450 | { | ||||||
| 14451 | 0 | 0 | warn_msg ( | ||||
| 14452 | "Two static routes for $network->{name}\n", | ||||||
| 14453 | " via $interface->{name} and", | ||||||
| 14454 | " $interface2->{name}" | ||||||
| 14455 | ); | ||||||
| 14456 | } | ||||||
| 14457 | } | ||||||
| 14458 | } | ||||||
| 14459 | else { | ||||||
| 14460 | 215 | 288 | $net2intf{$network} = $interface; | ||||
| 14461 | } | ||||||
| 14462 | 226 | 374 | unless ($interface->{routing}) { | ||||
| 14463 | 226 | 199 | my $group = $hop->{redundancy_interfaces}; | ||||
| 14464 | 226 | 312 | if ($group) { | ||||
| 14465 | 16 16 | 13 28 | push @{ $net2group{$network} }, $hop; | ||||
| 14466 | } | ||||||
| 14467 | 226 | 329 | if (my $hop2 = $net2hop{$network}) { | ||||
| 14468 | |||||||
| 14469 | # Network is reached via two different hops. | ||||||
| 14470 | # Check if both belong to same group | ||||||
| 14471 | # of redundancy interfaces. | ||||||
| 14472 | 11 | 12 | my $group2 = $hop2->{redundancy_interfaces}; | ||||
| 14473 | 11 | 50 | if ($group && $group2 && $group eq $group2) { | ||||
| 14474 | |||||||
| 14475 | # Prevent multiple identical routes to | ||||||
| 14476 | # different interfaces | ||||||
| 14477 | # with identical virtual IP. | ||||||
| 14478 | 8 | 29 | delete $interface->{routes}->{$hop}->{$network}; | ||||
| 14479 | } | ||||||
| 14480 | else { | ||||||
| 14481 | 3 | 26 | warn_msg ( | ||||
| 14482 | "Two static routes for $network->{name}\n", | ||||||
| 14483 | " at $interface->{name}", | ||||||
| 14484 | " via $hop->{name} and $hop2->{name}" | ||||||
| 14485 | ); | ||||||
| 14486 | } | ||||||
| 14487 | } | ||||||
| 14488 | else { | ||||||
| 14489 | 215 | 510 | $net2hop{$network} = $hop; | ||||
| 14490 | } | ||||||
| 14491 | } | ||||||
| 14492 | } | ||||||
| 14493 | } | ||||||
| 14494 | 743 | 1131 | for my $net_ref (keys %net2group) { | ||||
| 14495 | 8 | 8 | my $hops = $net2group{$net_ref}; | ||||
| 14496 | 8 | 8 | my $hop1 = $hops->[0]; | ||||
| 14497 | 8 8 | 7 17 | next if @$hops == @{ $hop1->{redundancy_interfaces} }; | ||||
| 14498 | 2 | 4 | my $network = $interface->{routes}->{$hop1}->{$net_ref}; | ||||
| 14499 | |||||||
| 14500 | # A network is routed to a single physical interface. | ||||||
| 14501 | # It is probably a loopback interface of the same device. | ||||||
| 14502 | # Move hop from virtual to physical interface. | ||||||
| 14503 | 2 | 10 | if (@$hops == 1 && (my $phys_hop = $hop1->{orig_main})) { | ||||
| 14504 | 1 | 2 | delete $interface->{routes}->{$hop1}->{$net_ref}; | ||||
| 14505 | 1 | 2 | $interface->{routes}->{$phys_hop}->{$network} = $network; | ||||
| 14506 | 1 | 3 | $interface->{hop}->{$phys_hop} = $phys_hop; | ||||
| 14507 | } | ||||||
| 14508 | else { | ||||||
| 14509 | |||||||
| 14510 | # This occurs if different redundancy groups use | ||||||
| 14511 | # parts of of a group of routers. | ||||||
| 14512 | # More than 3 virtual interfaces together with | ||||||
| 14513 | # pathrestrictions have already been rejected. | ||||||
| 14514 | 1 | 4 | err_msg( | ||||
| 14515 | "$network->{name} is reached via $hop1->{name}\n", | ||||||
| 14516 | " but not via all related redundancy interfaces" | ||||||
| 14517 | ); | ||||||
| 14518 | } | ||||||
| 14519 | } | ||||||
| 14520 | |||||||
| 14521 | # Convert to array, because hash isn't needed any longer. | ||||||
| 14522 | # Array is sorted to get deterministic output. | ||||||
| 14523 | 743 | 2202 | $interface->{hop} = | ||||
| 14524 | 743 | 619 | [ sort by_name values %{ $interface->{hop} } ]; | ||||
| 14525 | } | ||||||
| 14526 | } | ||||||
| 14527 | 226 | 237 | return; | ||||
| 14528 | } | ||||||
| 14529 | |||||||
| 14530 | sub ios_route_code; | ||||||
| 14531 | sub prefix_code; | ||||||
| 14532 | sub full_prefix_code; | ||||||
| 14533 | sub address; | ||||||
| 14534 | |||||||
| 14535 | sub print_header { | ||||||
| 14536 | 529 | 0 | 489 | my ($router, $what) = @_; | |||
| 14537 | 529 | 559 | my $comment_char = $router->{model}->{comment_char}; | ||||
| 14538 | 529 | 747 | my $where = $router->{vrf_members} ? " for $router->{name}" : ''; | ||||
| 14539 | 529 | 980 | print "$comment_char [ $what$where ]\n"; | ||||
| 14540 | 529 | 595 | return; | ||||
| 14541 | } | ||||||
| 14542 | |||||||
| 14543 | sub print_routes { | ||||||
| 14544 | 252 | 0 | 226 | my ($router) = @_; | |||
| 14545 | 252 | 254 | my $model = $router->{model}; | ||||
| 14546 | 252 | 264 | my $type = $model->{routing}; | ||||
| 14547 | 252 | 241 | my $vrf = $router->{vrf}; | ||||
| 14548 | 252 | 231 | my $comment_char = $model->{comment_char}; | ||||
| 14549 | 252 | 267 | my $do_auto_default_route = $config{auto_default_route}; | ||||
| 14550 | 252 | 517 | my $crypto_type = $model->{crypto} || ''; | ||||
| 14551 | 252 | 211 | my %intf2hop2nets; | ||||
| 14552 | my @interfaces; | ||||||
| 14553 | 0 | 0 | my %mask2ip2net; | ||||
| 14554 | 0 | 0 | my %net2hop_info; | ||||
| 14555 | 0 | 0 | my %net2no_opt; | ||||
| 14556 | 252 252 | 217 358 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 14557 | 620 | 962 | next if $interface->{ip} eq 'bridged'; | ||||
| 14558 | 610 | 866 | if ($interface->{routing}) { | ||||
| 14559 | 182 | 137 | $do_auto_default_route = 0; | ||||
| 14560 | 182 | 220 | next; | ||||
| 14561 | } | ||||||
| 14562 | |||||||
| 14563 | 428 | 371 | push @interfaces, $interface; | ||||
| 14564 | |||||||
| 14565 | # ASA with site-to-site VPN needs individual routes for each peer. | ||||||
| 14566 | 428 | 743 | if ($interface->{hub} && $crypto_type eq 'ASA') { | ||||
| 14567 | 5 | 5 | $do_auto_default_route = 0; | ||||
| 14568 | } | ||||||
| 14569 | 428 | 352 | my $no_nat_set = $interface->{no_nat_set}; | ||||
| 14570 | |||||||
| 14571 | 428 428 | 333 704 | for my $hop (@{ $interface->{hop} }) { | ||||
| 14572 | 117 | 161 | my $hop_info = [ $interface, $hop ]; | ||||
| 14573 | |||||||
| 14574 | # A hash having all networks reachable via current hop | ||||||
| 14575 | # both as key and as value. | ||||||
| 14576 | 117 | 200 | my $net_hash = $interface->{routes}->{$hop}; | ||||
| 14577 | 117 | 183 | for my $network (values %$net_hash) { | ||||
| 14578 | 175 | 271 | my $nat_network = get_nat_network($network, $no_nat_set); | ||||
| 14579 | 175 175 | 154 251 | my ($ip, $mask) = @{$nat_network}{ 'ip', 'mask' }; | ||||
| 14580 | 175 | 341 | if ($ip == 0 and $mask == 0) { | ||||
| 14581 | 10 | 10 | $do_auto_default_route = 0; | ||||
| 14582 | } | ||||||
| 14583 | |||||||
| 14584 | # Implicitly overwrite duplicate networks. | ||||||
| 14585 | 175 | 1240 | $mask2ip2net{$mask}->{$ip} = $nat_network; | ||||
| 14586 | 175 | 521 | $net2hop_info{$nat_network} = $hop_info; | ||||
| 14587 | } | ||||||
| 14588 | } | ||||||
| 14589 | } | ||||||
| 14590 | 252 | 633 | return if not @interfaces; | ||||
| 14591 | |||||||
| 14592 | # Find and remove duplicate networks. | ||||||
| 14593 | # Go from smaller to larger networks. | ||||||
| 14594 | 179 | 374 | for my $mask (reverse sort keys %mask2ip2net) { | ||||
| 14595 | 131 | 335 | NETWORK: | ||||
| 14596 | 131 | 120 | for my $ip (sort numerically keys %{ $mask2ip2net{$mask} }) { | ||||
| 14597 | 170 | 178 | my $small = $mask2ip2net{$mask}->{$ip}; | ||||
| 14598 | 170 | 230 | my $hop_info = $net2hop_info{$small}; | ||||
| 14599 | 170 | 172 | my ($interface, $hop) = @$hop_info; | ||||
| 14600 | |||||||
| 14601 | # ASA with site-to-site VPN needs individual routes for each peer. | ||||||
| 14602 | 170 | 375 | if (!($interface->{hub} && $crypto_type eq 'ASA')) { | ||||
| 14603 | |||||||
| 14604 | 154 | 144 | my $m = $mask; | ||||
| 14605 | 154 | 126 | my $i = $ip; | ||||
| 14606 | 154 | 230 | while ($m) { | ||||
| 14607 | |||||||
| 14608 | # Clear upper bit, because left shift is undefined | ||||||
| 14609 | # otherwise. | ||||||
| 14610 | 3443 | 2488 | $m = $m & 0x7fffffff; | ||||
| 14611 | 3443 | 2401 | $m <<= 1; | ||||
| 14612 | 3443 | 2418 | $i = $i & $m; # Perl bug #108480. | ||||
| 14613 | 3443 | 6642 | my $ip2net = $mask2ip2net{$m} or next; | ||||
| 14614 | 44 | 103 | my $big = $mask2ip2net{$m}->{$i} or next; | ||||
| 14615 | |||||||
| 14616 | # $small is subnet of $big. | ||||||
| 14617 | # If both use the same hop, then $small is redundant. | ||||||
| 14618 | 25 | 61 | if ($net2hop_info{$big} eq $hop_info) { | ||||
| 14619 | # debug "Removed: $small->{name} -> $hop->{name}"; | ||||||
| 14620 | 14 | 40 | next NETWORK; | ||||
| 14621 | } | ||||||
| 14622 | |||||||
| 14623 | # Otherwise $small isn't redundant, even if a bigger network | ||||||
| 14624 | # with same hop exists. | ||||||
| 14625 | # It must not be removed by default route later. | ||||||
| 14626 | 11 | 23 | $net2no_opt{$small} = 1; | ||||
| 14627 | # debug "No opt: $small->{name} -> $hop->{name}"; | ||||||
| 14628 | 11 | 12 | last; | ||||
| 14629 | } | ||||||
| 14630 | } | ||||||
| 14631 | 156 156 | 116 766 | push(@{ $intf2hop2nets{$interface}->{$hop} }, [ $ip, $mask, $small ]); | ||||
| 14632 | } | ||||||
| 14633 | } | ||||||
| 14634 | |||||||
| 14635 | 179 | 303 | if ($do_auto_default_route) { | ||||
| 14636 | |||||||
| 14637 | # Find interface and hop with largest number of routing entries. | ||||||
| 14638 | 162 | 143 | my $max_intf; | ||||
| 14639 | my $max_hop; | ||||||
| 14640 | |||||||
| 14641 | # Substitute routes to one hop with a default route, | ||||||
| 14642 | # if there are at least two entries. | ||||||
| 14643 | 162 | 144 | my $max = 1; | ||||
| 14644 | 162 | 182 | for my $interface (@interfaces) { | ||||
| 14645 | 382 382 | 263 577 | for my $hop (@{ $interface->{hop} }) { | ||||
| 14646 | 123 101 | 266 321 | my $count = grep({ !$net2no_opt{$_->[2]} } | ||||
| 14647 | 101 | 78 | @{ $intf2hop2nets{$interface}->{$hop} || [] }); | ||||
| 14648 | 101 | 260 | if ($count > $max) { | ||||
| 14649 | 12 | 14 | $max_intf = $interface; | ||||
| 14650 | 12 | 12 | $max_hop = $hop; | ||||
| 14651 | 12 | 30 | $max = $count; | ||||
| 14652 | } | ||||||
| 14653 | } | ||||||
| 14654 | } | ||||||
| 14655 | 162 | 364 | if ($max_intf && $max_hop) { | ||||
| 14656 | |||||||
| 14657 | # Use default route for this direction. | ||||||
| 14658 | # But still generate routes for small networks | ||||||
| 14659 | # with supernet behind other hop. | ||||||
| 14660 | 37 | 69 | $intf2hop2nets{$max_intf}->{$max_hop} = | ||||
| 14661 | [ [ 0, 0 ], | ||||||
| 14662 | 12 | 26 | grep({ $net2no_opt{$_->[2]} } | ||||
| 14663 | 12 | 22 | @{ $intf2hop2nets{$max_intf}->{$max_hop} }) | ||||
| 14664 | ]; | ||||||
| 14665 | } | ||||||
| 14666 | } | ||||||
| 14667 | 179 | 332 | print_header($router, 'Routing'); | ||||
| 14668 | |||||||
| 14669 | 179 | 151 | my $ios_vrf; | ||||
| 14670 | 179 | 356 | $ios_vrf = $vrf ? "vrf $vrf " : '' if $type eq 'IOS'; | ||||
| 14671 | 179 | 165 | my $nxos_prefix = ''; | ||||
| 14672 | |||||||
| 14673 | 179 | 208 | for my $interface (@interfaces) { | ||||
| 14674 | 428 428 | 325 644 | for my $hop (@{ $interface->{hop} }) { | ||||
| 14675 | |||||||
| 14676 | # For unnumbered and negotiated interfaces use interface name | ||||||
| 14677 | # as next hop. | ||||||
| 14678 | 117 | 408 | my $hop_addr = | ||||
| 14679 | $interface->{ip} =~ /^(?:unnumbered|negotiated|tunnel)$/ | ||||||
| 14680 | ? $interface->{hardware}->{name} | ||||||
| 14681 | : print_ip $hop->{ip}; | ||||||
| 14682 | |||||||
| 14683 | 117 117 | 124 291 | for my $netinfo (@{ $intf2hop2nets{$interface}->{$hop} }) { | ||||
| 14684 | 132 | 231 | if ($config{comment_routes}) { | ||||
| 14685 | 0 | 0 | if (my $net = $netinfo->[2]) { | ||||
| 14686 | 0 | 0 | print("$comment_char route", | ||||
| 14687 | " $net->{name} -> $hop->{name}\n"); | ||||||
| 14688 | } | ||||||
| 14689 | } | ||||||
| 14690 | 132 | 307 | if ($type eq 'IOS') { | ||||
| 14691 | 39 | 64 | my $adr = ios_route_code($netinfo); | ||||
| 14692 | 39 | 174 | print "ip route $ios_vrf$adr $hop_addr\n"; | ||||
| 14693 | } | ||||||
| 14694 | elsif ($type eq 'NX-OS') { | ||||||
| 14695 | 18 | 47 | if ($vrf && ! $nxos_prefix) { | ||||
| 14696 | |||||||
| 14697 | # Print "vrf context" only once | ||||||
| 14698 | # and indent "ip route" commands. | ||||||
| 14699 | 4 | 10 | print "vrf context $vrf\n"; | ||||
| 14700 | 4 | 5 | $nxos_prefix = ' '; | ||||
| 14701 | } | ||||||
| 14702 | 18 | 28 | my $adr = full_prefix_code($netinfo); | ||||
| 14703 | 18 | 66 | print "${nxos_prefix}ip route $adr $hop_addr\n"; | ||||
| 14704 | } | ||||||
| 14705 | elsif ($type eq 'PIX') { | ||||||
| 14706 | 60 | 89 | my $adr = ios_route_code($netinfo); | ||||
| 14707 | 60 | 350 | |||||
| 14708 | "route $interface->{hardware}->{name} $adr $hop_addr\n"; | ||||||
| 14709 | } | ||||||
| 14710 | elsif ($type eq 'iproute') { | ||||||
| 14711 | 15 | 25 | my $adr = prefix_code($netinfo); | ||||
| 14712 | 15 | 66 | print "ip route add $adr via $hop_addr\n"; | ||||
| 14713 | } | ||||||
| 14714 | elsif ($type eq 'none') { | ||||||
| 14715 | |||||||
| 14716 | # Do nothing. | ||||||
| 14717 | } | ||||||
| 14718 | else { | ||||||
| 14719 | 0 | 0 | internal_err("unexpected routing type '$type'"); | ||||
| 14720 | } | ||||||
| 14721 | } | ||||||
| 14722 | } | ||||||
| 14723 | } | ||||||
| 14724 | 179 | 760 | return; | ||||
| 14725 | } | ||||||
| 14726 | |||||||
| 14727 | ############################################################################## | ||||||
| 14728 | # NAT commands | ||||||
| 14729 | ############################################################################## | ||||||
| 14730 | |||||||
| 14731 | sub print_nat1 { | ||||||
| 14732 | 92 | 0 | 112 | my ($router, $print_dynamic, $print_static_host, $print_static) = @_; | |||
| 14733 | 92 | 101 | my $model = $router->{model}; | ||||
| 14734 | 92 | 94 | my $comment_char = $model->{comment_char}; | ||||
| 14735 | |||||||
| 14736 | 92 | 142 | print_header($router, 'NAT'); | ||||
| 14737 | |||||||
| 14738 | 131 | 254 | my @hardware = | ||||
| 14739 | 92 92 | 83 220 | sort { $a->{level} <=> $b->{level} } @{ $router->{hardware} }; | ||||
| 14740 | |||||||
| 14741 | 92 | 133 | for my $in_hw (@hardware) { | ||||
| 14742 | 208 | 418 | my $src_nat = $in_hw->{src_nat} or next; | ||||
| 14743 | 17 | 16 | my $in_nat = $in_hw->{no_nat_set}; | ||||
| 14744 | 17 | 20 | for my $out_hw (@hardware) { | ||||
| 14745 | |||||||
| 14746 | # Value is { net => net, .. } | ||||||
| 14747 | 44 | 105 | my $net_hash = $src_nat->{$out_hw} or next; | ||||
| 14748 | 21 | 19 | my $out_nat = $out_hw->{no_nat_set}; | ||||
| 14749 | |||||||
| 14750 | # Sorting is only needed for getting output deterministic. | ||||||
| 14751 | # For equal addresses look at the NAT address. | ||||||
| 14752 | 0 | 0 | my @networks = | ||||
| 14753 | sort { | ||||||
| 14754 | 21 | 35 | $a->{ip} <=> $b->{ip} | ||||
| 14755 | || $a->{mask} <=> $b->{mask} | ||||||
| 14756 | || get_nat_network($a, $out_nat) | ||||||
| 14757 | ->{ip} <=> get_nat_network($b, $out_nat)->{ip} | ||||||
| 14758 | } values %$net_hash; | ||||||
| 14759 | |||||||
| 14760 | 21 | 22 | for my $network (@networks) { | ||||
| 14761 | 21 | 30 | my ($in_ip, $in_mask, $in_dynamic) = | ||||
| 14762 | 21 | 21 | @{ get_nat_network($network, $in_nat) }{qw(ip mask dynamic)}; | ||||
| 14763 | 21 | 26 | my ($out_ip, $out_mask, $out_dynamic) = | ||||
| 14764 | 21 | 24 | @{ get_nat_network($network, $out_nat) }{qw(ip mask dynamic)}; | ||||
| 14765 | |||||||
| 14766 | # Ignore dynamic translation, which doesn't occur at | ||||||
| 14767 | # current router | ||||||
| 14768 | 21 | 73 | if ( $out_dynamic | ||||
| 14769 | and $in_dynamic | ||||||
| 14770 | and $out_dynamic eq $in_dynamic) | ||||||
| 14771 | { | ||||||
| 14772 | 0 | 0 | $out_dynamic = $in_dynamic = undef; | ||||
| 14773 | } | ||||||
| 14774 | |||||||
| 14775 | # We are talking about source addresses. | ||||||
| 14776 | 21 | 27 | if ($out_dynamic) { | ||||
| 14777 | |||||||
| 14778 | # Check for static NAT entries of hosts and interfaces. | ||||||
| 14779 | 15 15 15 | 14 21 19 | for my $host (@{ $network->{subnets} }, | ||||
| 14780 | @{ $network->{interfaces} }) | ||||||
| 14781 | { | ||||||
| 14782 | 18 | 51 | if (my $out_host_ip = $host->{nat}->{$out_dynamic}) { | ||||
| 14783 | 3 | 5 | my $pair = address($host, $in_nat); | ||||
| 14784 | 3 | 4 | my ($in_host_ip, $in_host_mask) = @$pair; | ||||
| 14785 | 3 | 6 | $print_static_host->( | ||||
| 14786 | $in_hw, $in_host_ip, $in_host_mask, $out_hw, | ||||||
| 14787 | $out_host_ip | ||||||
| 14788 | ); | ||||||
| 14789 | } | ||||||
| 14790 | } | ||||||
| 14791 | 15 | 24 | $print_dynamic->( | ||||
| 14792 | $in_hw, $in_ip, $in_mask, | ||||||
| 14793 | $out_hw, $out_ip, $out_mask | ||||||
| 14794 | ); | ||||||
| 14795 | } | ||||||
| 14796 | else { | ||||||
| 14797 | 6 | 10 | $print_static->($in_hw, $in_ip, $in_mask, $out_hw, $out_ip); | ||||
| 14798 | } | ||||||
| 14799 | } | ||||||
| 14800 | } | ||||||
| 14801 | } | ||||||
| 14802 | 92 | 150 | return; | ||||
| 14803 | } | ||||||
| 14804 | |||||||
| 14805 | sub print_pix_static { | ||||||
| 14806 | 86 | 0 | 89 | my ($router) = @_; | |||
| 14807 | |||||||
| 14808 | # Index for linking "global" and "nat" commands. | ||||||
| 14809 | 86 | 81 | my $dyn_index = 1; | ||||
| 14810 | |||||||
| 14811 | # Hash of indexes for reusing of NAT pools. | ||||||
| 14812 | 86 | 68 | my %global2index; | ||||
| 14813 | |||||||
| 14814 | # Hash of indexes for creating only a single "nat" command if mapped at | ||||||
| 14815 | # different interfaces. | ||||||
| 14816 | my %nat2index; | ||||||
| 14817 | |||||||
| 14818 | my $print_dynamic = sub { | ||||||
| 14819 | 11 | 15 | my ($in_hw, $in_ip, $in_mask, $out_hw, $out_ip, $out_mask) = @_; | ||||
| 14820 | 11 | 14 | my $in_name = $in_hw->{name}; | ||||
| 14821 | 11 | 11 | my $out_name = $out_hw->{name}; | ||||
| 14822 | |||||||
| 14823 | # Use a single "global" command if multiple networks are | ||||||
| 14824 | # mapped to a single pool. | ||||||
| 14825 | 11 | 28 | my $global_index = $global2index{$out_name}->{$out_ip}->{$out_mask}; | ||||
| 14826 | |||||||
| 14827 | # Use a single "nat" command if one network is mapped to | ||||||
| 14828 | # different pools at different interfaces. | ||||||
| 14829 | 11 | 22 | my $nat_index = $nat2index{$in_name}->{$in_ip}->{$in_mask}; | ||||
| 14830 | 11 | 28 | $global_index and $nat_index and internal_err(); | ||||
| 14831 | |||||||
| 14832 | 11 | 43 | my $index = $global_index || $nat_index || $dyn_index++; | ||||
| 14833 | 11 | 17 | if (not $global_index) { | ||||
| 14834 | 8 | 23 | $global2index{$out_name}->{$out_ip}->{$out_mask} = $index; | ||||
| 14835 | 8 | 8 | my $pool; | ||||
| 14836 | |||||||
| 14837 | # global (outside) 1 interface | ||||||
| 14838 | 8 | 14 | my $out_intf_ip = $out_hw->{interfaces}->[0]->{ip}; | ||||
| 14839 | 8 | 21 | if ($out_ip == $out_intf_ip && $out_mask == 0xffffffff) { | ||||
| 14840 | 0 | 0 | $pool = 'interface'; | ||||
| 14841 | } | ||||||
| 14842 | |||||||
| 14843 | # global (outside) 1 10.7.6.0-10.7.6.255 netmask 255.255.255.0 | ||||||
| 14844 | # nat (inside) 1 14.4.36.0 255.255.252.0 | ||||||
| 14845 | else { | ||||||
| 14846 | 8 | 12 | my $max = $out_ip | complement_32bit $out_mask; | ||||
| 14847 | 8 | 13 | my $mask = print_ip $out_mask; | ||||
| 14848 | 8 | 19 | my $range = | ||||
| 14849 | ($out_ip == $max) | ||||||
| 14850 | ? print_ip($out_ip) | ||||||
| 14851 | : print_ip($out_ip) . '-' . print_ip($max); | ||||||
| 14852 | 8 | 17 | $pool = "$range netmask $mask"; | ||||
| 14853 | } | ||||||
| 14854 | 8 | 36 | print "global ($out_name) $index $pool\n"; | ||||
| 14855 | } | ||||||
| 14856 | |||||||
| 14857 | 11 | 27 | if (not $nat_index) { | ||||
| 14858 | 9 | 25 | $nat2index{$in_name}->{$in_ip}->{$in_mask} = $index; | ||||
| 14859 | 9 | 12 | my $in = print_ip $in_ip; | ||||
| 14860 | 9 | 12 | my $mask = print_ip $in_mask; | ||||
| 14861 | 9 | 41 | print "nat ($in_name) $index $in $mask"; | ||||
| 14862 | 9 | 23 | print " outside" if $in_hw->{level} < $out_hw->{level}; | ||||
| 14863 | 9 | 32 | print "\n"; | ||||
| 14864 | } | ||||||
| 14865 | 86 | 414 | }; | ||||
| 14866 | my $print_static_host = sub { | ||||||
| 14867 | 2 | 6 | my ($in_hw, $in_host_ip, $in_host_mask, $out_hw, $out_host_ip) = @_; | ||||
| 14868 | 2 | 2 | my $in_name = $in_hw->{name}; | ||||
| 14869 | 2 | 4 | my $out_name = $out_hw->{name}; | ||||
| 14870 | 2 | 2 | my $in = print_ip $in_host_ip; | ||||
| 14871 | 2 | 3 | my $mask = print_ip $in_host_mask; | ||||
| 14872 | 2 | 3 | my $out = print_ip $out_host_ip; | ||||
| 14873 | 2 | 20 | print "static ($in_name,$out_name) $out $in netmask $mask\n"; | ||||
| 14874 | 86 | 226 | }; | ||||
| 14875 | my $print_static = sub { | ||||||
| 14876 | 6 | 8 | my ($in_hw, $in_ip, $in_mask, $out_hw, $out_ip) = @_; | ||||
| 14877 | 6 | 37 | if ( $in_hw->{level} > $out_hw->{level} | ||||
| 14878 | || $in_hw->{need_identity_nat} | ||||||
| 14879 | || $in_ip != $out_ip) | ||||||
| 14880 | { | ||||||
| 14881 | 6 | 7 | my $in_name = $in_hw->{name}; | ||||
| 14882 | 6 | 5 | my $out_name = $out_hw->{name}; | ||||
| 14883 | 6 | 9 | my $in = print_ip $in_ip; | ||||
| 14884 | 6 | 8 | my $out = print_ip $out_ip; | ||||
| 14885 | 6 | 8 | my $mask = print_ip $in_mask; | ||||
| 14886 | |||||||
| 14887 | # static (inside,outside) \ | ||||||
| 14888 | # 10.111.0.0 111.0.0.0 netmask 255.255.252.0 | ||||||
| 14889 | 6 | 57 | print "static ($in_name,$out_name) $out $in netmask $mask\n"; | ||||
| 14890 | } | ||||||
| 14891 | 86 | 236 | }; | ||||
| 14892 | 86 | 142 | print_nat1($router, $print_dynamic, $print_static_host, $print_static); | ||||
| 14893 | 86 86 | 73 116 | for my $in_hw (@{ $router->{hardware} }) { | ||||
| 14894 | 194 | 348 | next if not $in_hw->{need_nat_0}; | ||||
| 14895 | 0 | 0 | print "nat ($in_hw->{name}) 0 0.0.0.0 0.0.0.0\n"; | ||||
| 14896 | } | ||||||
| 14897 | 86 | 2268 | return; | ||||
| 14898 | } | ||||||
| 14899 | |||||||
| 14900 | sub print_asa_nat { | ||||||
| 14901 | 6 | 0 | 7 | my ($router) = @_; | |||
| 14902 | |||||||
| 14903 | # Hash for re-using object definitions. | ||||||
| 14904 | 6 | 6 | my %objects; | ||||
| 14905 | |||||||
| 14906 | my $subnet_obj = sub { | ||||||
| 14907 | 6 | 6 | my ($ip, $mask) = @_; | ||||
| 14908 | 6 | 12 | my $p_ip = print_ip($ip); | ||||
| 14909 | 6 | 8 | my $p_mask = print_ip($mask); | ||||
| 14910 | 6 | 12 | my $name = "${p_ip}_${p_mask}"; | ||||
| 14911 | 6 | 10 | if (not $objects{$name}) { | ||||
| 14912 | 4 | 9 | print "object network $name\n"; | ||||
| 14913 | 4 | 6 | print " subnet $p_ip $p_mask\n"; | ||||
| 14914 | 4 | 7 | $objects{$name} = $name; | ||||
| 14915 | } | ||||||
| 14916 | 6 | 9 | return $name; | ||||
| 14917 | 6 | 25 | }; | ||||
| 14918 | my $range_obj = sub { | ||||||
| 14919 | 4 | 6 | my ($ip, $mask) = @_; | ||||
| 14920 | 4 | 4 | my $max = $ip | complement_32bit $mask; | ||||
| 14921 | 4 | 4 | my $p_ip = print_ip($ip); | ||||
| 14922 | 4 | 4 | my $name = $p_ip; | ||||
| 14923 | 4 | 3 | my $sub_cmd; | ||||
| 14924 | 4 | 6 | if ($ip == $max) { | ||||
| 14925 | 2 | 3 | $sub_cmd = "host $p_ip"; | ||||
| 14926 | } | ||||||
| 14927 | else { | ||||||
| 14928 | 2 | 3 | my $p_max = print_ip($max); | ||||
| 14929 | 2 | 4 | $name .= "-$p_max"; | ||||
| 14930 | 2 | 3 | $sub_cmd = "range $p_ip $p_max"; | ||||
| 14931 | } | ||||||
| 14932 | 4 | 9 | if (not $objects{$name}) { | ||||
| 14933 | 3 | 6 | print "object network $name\n"; | ||||
| 14934 | 3 | 5 | print " $sub_cmd\n"; | ||||
| 14935 | 3 | 4 | $objects{$name} = $name; | ||||
| 14936 | } | ||||||
| 14937 | 4 | 5 | return $name; | ||||
| 14938 | 6 | 23 | }; | ||||
| 14939 | |||||||
| 14940 | my $print_dynamic = sub { | ||||||
| 14941 | 4 | 6 | my ($in_hw, $in_ip, $in_mask, $out_hw, $out_ip, $out_mask) = @_; | ||||
| 14942 | 4 | 4 | my $in_name = $in_hw->{name}; | ||||
| 14943 | 4 | 5 | my $out_name = $out_hw->{name}; | ||||
| 14944 | 4 | 5 | my $in_obj = $subnet_obj->($in_ip, $in_mask); | ||||
| 14945 | 4 | 3 | my $out_obj; | ||||
| 14946 | |||||||
| 14947 | # NAT to interface | ||||||
| 14948 | 4 | 4 | my $out_intf_ip = $out_hw->{interfaces}->[0]->{ip}; | ||||
| 14949 | 4 | 10 | if ($out_ip == $out_intf_ip && $out_mask == 0xffffffff) { | ||||
| 14950 | 0 | 0 | $out_obj = 'interface'; | ||||
| 14951 | } | ||||||
| 14952 | else { | ||||||
| 14953 | 4 | 4 | $out_obj = $range_obj->($out_ip, $out_mask); | ||||
| 14954 | } | ||||||
| 14955 | 4 | 28 | print("nat ($in_name,$out_name) source dynamic $in_obj $out_obj\n"); | ||||
| 14956 | 6 | 20 | }; | ||||
| 14957 | my $print_static_host = sub { | ||||||
| 14958 | 1 | 1 | my ($in_hw, $in_host_ip, $in_host_mask, $out_hw, $out_host_ip) = @_; | ||||
| 14959 | 1 | 2 | my $in_name = $in_hw->{name}; | ||||
| 14960 | 1 | 1 | my $out_name = $out_hw->{name}; | ||||
| 14961 | 1 | 2 | my $in_host_obj = $subnet_obj->($in_host_ip, $in_host_mask); | ||||
| 14962 | 1 | 2 | my $out_host_obj = $subnet_obj->($out_host_ip, $in_host_mask); | ||||
| 14963 | |||||||
| 14964 | # Print with line number 1 because static host NAT must be | ||||||
| 14965 | # inserted in front of dynamic network NAT. | ||||||
| 14966 | 1 | 6 | print("nat ($in_name,$out_name) 1 source static", | ||||
| 14967 | " $in_host_obj $out_host_obj\n"); | ||||||
| 14968 | 6 | 25 | }; | ||||
| 14969 | my $print_static = sub { | ||||||
| 14970 | 0 | 0 | my ($in_hw, $in_ip, $in_mask, $out_hw, $out_ip) = @_; | ||||
| 14971 | 0 | 0 | my $in_name = $in_hw->{name}; | ||||
| 14972 | 0 | 0 | my $out_name = $out_hw->{name}; | ||||
| 14973 | 0 | 0 | my $in_obj = $subnet_obj->($in_ip, $in_mask); | ||||
| 14974 | 0 | 0 | my $out_obj = $subnet_obj->($out_ip, $in_mask); | ||||
| 14975 | 0 | 0 | print("nat ($in_name,$out_name) source static $in_obj $out_obj\n"); | ||||
| 14976 | 6 | 21 | }; | ||||
| 14977 | 6 | 11 | print_nat1($router, $print_dynamic, $print_static_host, $print_static); | ||||
| 14978 | 6 | 103 | return; | ||||
| 14979 | } | ||||||
| 14980 | |||||||
| 14981 | sub optimize_nat_networks { | ||||||
| 14982 | 92 | 0 | 95 | my ($router) = @_; | |||
| 14983 | 92 92 | 88 154 | my @hardware = @{ $router->{hardware} }; | ||||
| 14984 | 92 | 120 | for my $in_hw (@hardware) { | ||||
| 14985 | 208 | 397 | my $src_nat = $in_hw->{src_nat} or next; | ||||
| 14986 | 17 | 17 | my $in_nat = $in_hw->{no_nat_set}; | ||||
| 14987 | 17 | 18 | for my $out_hw (@hardware) { | ||||
| 14988 | |||||||
| 14989 | # Value is { net => net, .. } | ||||||
| 14990 | 44 | 108 | my $net_hash = $src_nat->{$out_hw} or next; | ||||
| 14991 | 21 | 21 | my $out_nat = $out_hw->{no_nat_set}; | ||||
| 14992 | |||||||
| 14993 | # Prevent duplicate entries from different networks | ||||||
| 14994 | # translated to one identical address. | ||||||
| 14995 | 21 | 23 | my @has_indentical; | ||||
| 14996 | 21 | 37 | for my $network (values %$net_hash) { | ||||
| 14997 | 21 | 51 | my $identical = $network->{is_identical} or next; | ||||
| 14998 | 3 | 5 | my $in = $identical->{$in_nat}; | ||||
| 14999 | 3 | 3 | my $out = $identical->{$out_nat}; | ||||
| 15000 | 3 | 10 | if ($in && $out && $in eq $out) { | ||||
| 15001 | 0 | 0 | push @has_indentical, $network; | ||||
| 15002 | } | ||||||
| 15003 | } | ||||||
| 15004 | 21 | 26 | for my $network (@has_indentical) { | ||||
| 15005 | 0 | 0 | delete $net_hash->{$network}; | ||||
| 15006 | 0 | 0 | my $one_net = $network->{is_identical}->{$out_nat}; | ||||
| 15007 | 0 | 0 | $net_hash->{$one_net} = $one_net; | ||||
| 15008 | } | ||||||
| 15009 | |||||||
| 15010 | # Remove redundant networks. | ||||||
| 15011 | # A network is redundant if some enclosing network is found | ||||||
| 15012 | # in both NAT domains of incoming and outgoing interface. | ||||||
| 15013 | 21 | 32 | for my $network (values %$net_hash) { | ||||
| 15014 | 21 | 29 | my $net = $network->{is_in}->{$out_nat}; | ||||
| 15015 | 21 | 59 | while ($net) { | ||||
| 15016 | 3 | 3 | my $net2; | ||||
| 15017 | 3 | 10 | if ( $net_hash->{$net} | ||||
| 15018 | and $net2 = $network->{is_in}->{$in_nat} | ||||||
| 15019 | and $net_hash->{$net2}) | ||||||
| 15020 | { | ||||||
| 15021 | 0 | 0 | delete $net_hash->{$network}; | ||||
| 15022 | 0 | 0 | last; | ||||
| 15023 | } | ||||||
| 15024 | else { | ||||||
| 15025 | 3 | 10 | $net = $net->{is_in}->{$out_nat}; | ||||
| 15026 | } | ||||||
| 15027 | } | ||||||
| 15028 | } | ||||||
| 15029 | } | ||||||
| 15030 | } | ||||||
| 15031 | 92 | 123 | return; | ||||
| 15032 | } | ||||||
| 15033 | |||||||
| 15034 | sub print_nat { | ||||||
| 15035 | 248 | 0 | 211 | my ($router) = @_; | |||
| 15036 | 248 | 252 | my $model = $router->{model}; | ||||
| 15037 | |||||||
| 15038 | # NAT commands not implemented for other models. | ||||||
| 15039 | 248 | 560 | return if not $model->{has_interface_level}; | ||||
| 15040 | |||||||
| 15041 | 92 | 156 | optimize_nat_networks($router); | ||||
| 15042 | 92 | 145 | if ($model->{v8_4}) { | ||||
| 15043 | |||||||
| 15044 | 6 | 14 | print_asa_nat($router); | ||||
| 15045 | } | ||||||
| 15046 | else { | ||||||
| 15047 | 86 | 137 | print_pix_static($router); | ||||
| 15048 | } | ||||||
| 15049 | 92 | 177 | return; | ||||
| 15050 | } | ||||||
| 15051 | |||||||
| 15052 | ############################################################################## | ||||||
| 15053 | # Distributing rules to managed devices | ||||||
| 15054 | ############################################################################## | ||||||
| 15055 | |||||||
| 15056 | sub distribute_rule { | ||||||
| 15057 | 702 | 0 | 630 | my ($rule, $in_intf, $out_intf) = @_; | |||
| 15058 | |||||||
| 15059 | # Traffic from src reaches this router via in_intf | ||||||
| 15060 | # and leaves it via out_intf. | ||||||
| 15061 | # in_intf is undefined if src is an interface of current router. | ||||||
| 15062 | # out_intf is undefined if dst is an interface of current router. | ||||||
| 15063 | # Outgoing packets from a router itself are never filtered. | ||||||
| 15064 | 702 | 977 | return unless $in_intf; | ||||
| 15065 | 647 | 601 | my $router = $in_intf->{router}; | ||||
| 15066 | 647 | 1024 | return if not $router->{managed}; | ||||
| 15067 | 625 | 541 | my $model = $router->{model}; | ||||
| 15068 | |||||||
| 15069 | # Rules of type stateless must only be processed at | ||||||
| 15070 | # - stateless routers or | ||||||
| 15071 | # - routers which are stateless for packets destined for | ||||||
| 15072 | # their own interfaces or | ||||||
| 15073 | # - stateless tunnel interfaces of ASA-VPN. | ||||||
| 15074 | 625 | 909 | if ($rule->{stateless}) { | ||||
| 15075 | 78 | 177 | if ( | ||||
| 15076 | not( $model->{stateless} | ||||||
| 15077 | or not $out_intf and $model->{stateless_self}) | ||||||
| 15078 | ) | ||||||
| 15079 | { | ||||||
| 15080 | 17 | 25 | return; | ||||
| 15081 | } | ||||||
| 15082 | } | ||||||
| 15083 | |||||||
| 15084 | # Rules of type stateless_icmp must only be processed at routers | ||||||
| 15085 | # which don't handle stateless_icmp automatically; | ||||||
| 15086 | 608 | 1037 | return if $rule->{stateless_icmp} and not $model->{stateless_icmp}; | ||||
| 15087 | |||||||
| 15088 | 608 | 498 | my $dst = $rule->{dst}; | ||||
| 15089 | 608 | 514 | my $intf_hash = $router->{crosslink_intf_hash}; | ||||
| 15090 | |||||||
| 15091 | # Rule to managed interface must be processed | ||||||
| 15092 | # - at the corresponding router or | ||||||
| 15093 | # - at the edge of a cluster of crosslinked routers | ||||||
| 15094 | # even if the rule is marked as deleted, | ||||||
| 15095 | # because code for interface is placed separately into {intf_rules}. | ||||||
| 15096 | 608 | 855 | if ($rule->{deleted}) { | ||||
| 15097 | |||||||
| 15098 | # We are at an intermediate router. | ||||||
| 15099 | 1 | 3 | return if $out_intf and (!$intf_hash || !$intf_hash->{$dst}); | ||||
| 15100 | |||||||
| 15101 | # No code needed if it is deleted by another rule to the same interface. | ||||||
| 15102 | 1 | 2 | return if $rule->{deleted}->{managed_intf}; | ||||
| 15103 | } | ||||||
| 15104 | |||||||
| 15105 | # Don't generate code for src any:[interface:r.loopback] at router:r. | ||||||
| 15106 | 608 | 838 | return if $in_intf->{loopback}; | ||||
| 15107 | |||||||
| 15108 | # Adapt rule to dynamic NAT. | ||||||
| 15109 | 608 | 930 | if (my $dynamic_nat = $rule->{dynamic_nat}) { | ||||
| 15110 | 0 | 0 | my $no_nat_set = $in_intf->{no_nat_set}; | ||||
| 15111 | 0 | 0 | my $orig_rule = $rule; | ||||
| 15112 | 0 | 0 | for my $where (split(/,/, $dynamic_nat)) { | ||||
| 15113 | 0 | 0 | my $obj = $rule->{$where}; | ||||
| 15114 | 0 | 0 | my $network = $obj->{network}; | ||||
| 15115 | 0 | 0 | my $nat_network = get_nat_network($network, $no_nat_set); | ||||
| 15116 | 0 | 0 | next if $nat_network eq $network; | ||||
| 15117 | 0 | 0 | my $nat_tag = $nat_network->{dynamic} or next; | ||||
| 15118 | |||||||
| 15119 | # Ignore object with static translation. | ||||||
| 15120 | 0 | 0 | next if $obj->{nat}->{$nat_tag}; | ||||
| 15121 | |||||||
| 15122 | # Otherwise, filtering occurs at other router, therefore | ||||||
| 15123 | # the whole network can pass here. | ||||||
| 15124 | # But attention, this assumption only holds, if the other | ||||||
| 15125 | # router filters fully. Hence disable optimization of | ||||||
| 15126 | # secondary rules. | ||||||
| 15127 | 0 | 0 | delete $orig_rule->{some_non_secondary}; | ||||
| 15128 | 0 | 0 | delete $orig_rule->{some_primary}; | ||||
| 15129 | |||||||
| 15130 | # Permit whole network, because no static address is known. | ||||||
| 15131 | # Make a copy of current rule, because the original rule | ||||||
| 15132 | # must not be changed. | ||||||
| 15133 | 0 | 0 | $rule = { %$rule, $where => $network }; | ||||
| 15134 | } | ||||||
| 15135 | } | ||||||
| 15136 | |||||||
| 15137 | 608 | 447 | my $key; | ||||
| 15138 | |||||||
| 15139 | # Packets for the router itself or for some interface of a | ||||||
| 15140 | # crosslinked cluster of routers (only IOS, NX-OS with "need_protect"). | ||||||
| 15141 | 608 | 1814 | if (!$out_intf || $intf_hash && $intf_hash->{$dst}) { | ||||
| 15142 | |||||||
| 15143 | # Packets for the router itself. For PIX we can only reach that | ||||||
| 15144 | # interface, where traffic enters the PIX. | ||||||
| 15145 | 121 | 211 | if ($model->{filter} eq 'PIX') { | ||||
| 15146 | 32 | 96 | if ($dst eq $in_intf) { | ||||
| 15147 | } | ||||||
| 15148 | elsif ($dst eq $network_00 or $dst eq $in_intf->{network}) { | ||||||
| 15149 | |||||||
| 15150 | # Ignore rule, because generated code would permit traffic | ||||||
| 15151 | # to cleartext interface as well. | ||||||
| 15152 | 8 | 16 | return if $in_intf->{ip} eq 'tunnel'; | ||||
| 15153 | |||||||
| 15154 | # Change destination in $rule to interface. | ||||||
| 15155 | # Make a copy of current rule, because the | ||||||
| 15156 | # original rule must not be changed. | ||||||
| 15157 | 8 | 18 | $rule = {%$rule}; | ||||
| 15158 | 8 | 14 | $rule->{dst} = $in_intf; | ||||
| 15159 | } | ||||||
| 15160 | |||||||
| 15161 | # Permit management access through tunnel. | ||||||
| 15162 | # On ASA device use command "management-access". | ||||||
| 15163 | # Permit management access through bridged interface. | ||||||
| 15164 | elsif ($in_intf->{ip} =~ /^(?:tunnel|bridged)/) { | ||||||
| 15165 | } | ||||||
| 15166 | |||||||
| 15167 | # Silently ignore everything else. | ||||||
| 15168 | else { | ||||||
| 15169 | 0 | 0 | return; | ||||
| 15170 | } | ||||||
| 15171 | } | ||||||
| 15172 | 121 | 115 | $key = 'intf_rules'; | ||||
| 15173 | } | ||||||
| 15174 | elsif ($out_intf->{hardware}->{need_out_acl}) { | ||||||
| 15175 | 9 | 9 | $key = 'out_rules'; | ||||
| 15176 | 9 | 22 | if (not $in_intf->{hardware}->{no_in_acl}) { | ||||
| 15177 | 2 2 | 2 9 | push @{ $in_intf->{hardware}->{rules} }, $rule; | ||||
| 15178 | } | ||||||
| 15179 | } | ||||||
| 15180 | else { | ||||||
| 15181 | 478 | 440 | $key = 'rules'; | ||||
| 15182 | } | ||||||
| 15183 | |||||||
| 15184 | 608 | 2049 | if ($in_intf->{ip} eq 'tunnel') { | ||||
| 15185 | |||||||
| 15186 | # Rules for single software clients are stored individually. | ||||||
| 15187 | # Consistency checks have already been done at expand_crypto. | ||||||
| 15188 | # Rules are needed at tunnel for generating split tunnel ACL | ||||||
| 15189 | # regardless of $router->{no_crypto_filter} value. | ||||||
| 15190 | 39 | 58 | if (my $id2rules = $in_intf->{id_rules}) { | ||||
| 15191 | 22 | 20 | my $src = $rule->{src}; | ||||
| 15192 | 22 | 25 | if (is_subnet $src) { | ||||
| 15193 | 22 | 33 | my $id = $src->{id} | ||||
| 15194 | or internal_err("$src->{name} must have ID"); | ||||||
| 15195 | 22 | 42 | my $id_intf = $id2rules->{$id} | ||||
| 15196 | or internal_err("No entry for $id at id_rules"); | ||||||
| 15197 | 22 22 | 15 33 | push @{ $id_intf->{$key} }, $rule; | ||||
| 15198 | } | ||||||
| 15199 | elsif (is_network $src) { | ||||||
| 15200 | 0 | 0 | $src->{has_id_hosts} | ||||
| 15201 | or internal_err("$src->{name} must have ID-hosts\n ", | ||||||
| 15202 | print_rule $rule); | ||||||
| 15203 | 0 0 0 | 0 0 0 | for my $id (map { $_->{id} } @{ $src->{hosts} }) { | ||||
| 15204 | 0 0 | 0 0 | push @{ $id2rules->{$id}->{$key} }, $rule; | ||||
| 15205 | } | ||||||
| 15206 | } | ||||||
| 15207 | else { | ||||||
| 15208 | 0 | 0 | internal_err( | ||||
| 15209 | "Expected host or network as src but got $src->{name}\n ", | ||||||
| 15210 | print_rule $rule); | ||||||
| 15211 | } | ||||||
| 15212 | } | ||||||
| 15213 | |||||||
| 15214 | 39 | 63 | if ($router->{no_crypto_filter}) { | ||||
| 15215 | 36 36 | 25 57 | push @{ $in_intf->{real_interface}->{hardware}->{$key} }, $rule; | ||||
| 15216 | } | ||||||
| 15217 | |||||||
| 15218 | # Rules are needed at tunnel for generating detailed_crypto_acl. | ||||||
| 15219 | 39 | 61 | if (not $in_intf->{id_rules}) { | ||||
| 15220 | 17 17 | 13 24 | push @{ $in_intf->{$key} }, $rule; | ||||
| 15221 | } | ||||||
| 15222 | } | ||||||
| 15223 | elsif ($key eq 'out_rules') { | ||||||
| 15224 | 9 9 | 8 16 | push @{ $out_intf->{hardware}->{$key} }, $rule; | ||||
| 15225 | } | ||||||
| 15226 | |||||||
| 15227 | # Remember outgoing interface. | ||||||
| 15228 | elsif ($key eq 'rules' and $model->{has_io_acl}) { | ||||||
| 15229 | 63 63 | 49 141 | push @{ $in_intf->{hardware}->{io_rules} | ||||
| 15230 | ->{ $out_intf->{hardware}->{name} } }, $rule; | ||||||
| 15231 | } | ||||||
| 15232 | else { | ||||||
| 15233 | 497 497 | 377 789 | push @{ $in_intf->{hardware}->{$key} }, $rule; | ||||
| 15234 | } | ||||||
| 15235 | 608 | 883 | return; | ||||
| 15236 | } | ||||||
| 15237 | |||||||
| 15238 | my $permit_any_rule; | ||||||
| 15239 | |||||||
| 15240 | sub add_router_acls { | ||||||
| 15241 | 155 | 0 | 203 | for my $router (@managed_routers) { | |||
| 15242 | 257 | 269 | my $has_io_acl = $router->{model}->{has_io_acl}; | ||||
| 15243 | 257 257 | 208 324 | for my $hardware (@{ $router->{hardware} }) { | ||||
| 15244 | |||||||
| 15245 | # Some managed devices are connected by a crosslink network. | ||||||
| 15246 | # Permit any traffic at the internal crosslink interface. | ||||||
| 15247 | 559 | 820 | if ($hardware->{crosslink}) { | ||||
| 15248 | |||||||
| 15249 | # We can savely change rules at hardware interface | ||||||
| 15250 | # because it has been checked that no other logical | ||||||
| 15251 | # networks are attached to the same hardware. | ||||||
| 15252 | # | ||||||
| 15253 | # Substitute rules for each outgoing interface. | ||||||
| 15254 | 10 | 15 | if ($has_io_acl) { | ||||
| 15255 | 0 0 | 0 0 | for my $rules (values %{ $hardware->{io_rules} }) { | ||||
| 15256 | 0 | 0 | $rules = [$permit_any_rule]; | ||||
| 15257 | } | ||||||
| 15258 | } | ||||||
| 15259 | else { | ||||||
| 15260 | 10 | 16 | $hardware->{rules} = [$permit_any_rule]; | ||||
| 15261 | 10 | 16 | if ($hardware->{need_out_acl}) { | ||||
| 15262 | 0 | 0 | $hardware->{out_rules} = [$permit_any_rule]; | ||||
| 15263 | } | ||||||
| 15264 | } | ||||||
| 15265 | 10 | 18 | $hardware->{intf_rules} = [$permit_any_rule]; | ||||
| 15266 | 10 | 13 | next; | ||||
| 15267 | } | ||||||
| 15268 | |||||||
| 15269 | 549 549 | 389 636 | for my $interface (@{ $hardware->{interfaces} }) { | ||||
| 15270 | |||||||
| 15271 | # Current router is used as default router even for | ||||||
| 15272 | # some internal networks. | ||||||
| 15273 | 600 | 843 | if ($interface->{reroute_permit}) { | ||||
| 15274 | 0 0 | 0 0 | for my $net (@{ $interface->{reroute_permit} }) { | ||||
| 15275 | |||||||
| 15276 | # Prepend to all other rules. | ||||||
| 15277 | 0 | 0 | unshift( | ||||
| 15278 | @{ | ||||||
| 15279 | 0 | 0 | $has_io_acl | ||||
| 15280 | |||||||
| 15281 | # Incoming and outgoing interface are equal. | ||||||
| 15282 | ? $hardware->{io_rules}->{ $hardware->{name} } | ||||||
| 15283 | : $hardware->{rules} | ||||||
| 15284 | }, | ||||||
| 15285 | { | ||||||
| 15286 | src => $network_00, | ||||||
| 15287 | dst => $net, | ||||||
| 15288 | prt => $prt_ip | ||||||
| 15289 | } | ||||||
| 15290 | ); | ||||||
| 15291 | } | ||||||
| 15292 | } | ||||||
| 15293 | |||||||
| 15294 | # Is dynamic routing used? | ||||||
| 15295 | 600 | 878 | if (my $routing = $interface->{routing}) { | ||||
| 15296 | 182 | 457 | if($routing->{name} !~ /^(?:manual|dynamic)$/) { | ||||
| 15297 | 1 | 1 | my $prt = $routing->{prt}; | ||||
| 15298 | 1 | 3 | if (my $dst_range = $prt->{dst_range}) { | ||||
| 15299 | 0 | 0 | $prt = $dst_range; | ||||
| 15300 | } | ||||||
| 15301 | 1 | 1 | my $network = $interface->{network}; | ||||
| 15302 | |||||||
| 15303 | # Permit multicast packets from current network. | ||||||
| 15304 | 1 1 | 1 2 | for my $mcast (@{ $routing->{mcast} }) { | ||||
| 15305 | 2 2 | 2 4 | push @{ $hardware->{intf_rules} }, | ||||
| 15306 | { | ||||||
| 15307 | src => $network, | ||||||
| 15308 | dst => $mcast, | ||||||
| 15309 | prt => $prt | ||||||
| 15310 | }; | ||||||
| 15311 | 2 | 4 | $ref2obj{$mcast} = $mcast; | ||||
| 15312 | } | ||||||
| 15313 | # Additionally permit unicast packets. | ||||||
| 15314 | # We use the network address as destination | ||||||
| 15315 | # instead of the interface address, | ||||||
| 15316 | # because we get fewer rules if the interface has | ||||||
| 15317 | # multiple addresses. | ||||||
| 15318 | 1 1 | 2 3 | push @{ $hardware->{intf_rules} }, | ||||
| 15319 | { | ||||||
| 15320 | src => $network, | ||||||
| 15321 | dst => $network, | ||||||
| 15322 | prt => $prt | ||||||
| 15323 | }; | ||||||
| 15324 | } | ||||||
| 15325 | } | ||||||
| 15326 | |||||||
| 15327 | # Handle multicast packets of redundancy protocols. | ||||||
| 15328 | 600 | 836 | if (my $type = $interface->{redundancy_type}) { | ||||
| 15329 | 14 | 14 | my $network = $interface->{network}; | ||||
| 15330 | 14 | 18 | my $mcast = $xxrp_info{$type}->{mcast}; | ||||
| 15331 | 14 | 16 | my $prt = $xxrp_info{$type}->{prt}; | ||||
| 15332 | 14 | 19 | if (my $dst_range = $prt->{dst_range}) { | ||||
| 15333 | 2 | 2 | $prt = $dst_range; | ||||
| 15334 | } | ||||||
| 15335 | 14 14 | 11 30 | push @{ $hardware->{intf_rules} }, | ||||
| 15336 | { | ||||||
| 15337 | src => $network, | ||||||
| 15338 | dst => $mcast, | ||||||
| 15339 | prt => $prt | ||||||
| 15340 | }; | ||||||
| 15341 | 14 | 26 | $ref2obj{$mcast} = $mcast; | ||||
| 15342 | } | ||||||
| 15343 | |||||||
| 15344 | # Handle DHCP requests. | ||||||
| 15345 | 600 | 1503 | if ($interface->{dhcp_server}) { | ||||
| 15346 | 1 1 | 1 5 | push @{ $hardware->{intf_rules} }, | ||||
| 15347 | { | ||||||
| 15348 | src => $network_00, | ||||||
| 15349 | dst => $network_00, | ||||||
| 15350 | prt => $prt_bootps->{dst_range} | ||||||
| 15351 | }; | ||||||
| 15352 | } | ||||||
| 15353 | } | ||||||
| 15354 | } | ||||||
| 15355 | } | ||||||
| 15356 | 155 | 158 | return; | ||||
| 15357 | } | ||||||
| 15358 | |||||||
| 15359 | # At least for $prt_esp and $prt_ah the ACL lines need to have a fixed order. | ||||||
| 15360 | # Otherwise, | ||||||
| 15361 | # - if the device is accessed over an IPSec tunnel | ||||||
| 15362 | # - and we change the ACL incrementally, | ||||||
| 15363 | # the connection may be lost. | ||||||
| 15364 | sub cmp_address { | ||||||
| 15365 | 36 | 0 | 28 | my ($obj) = @_; | |||
| 15366 | 36 | 29 | my $type = ref $obj; | ||||
| 15367 | 36 | 106 | if ($type eq 'Network' or $type eq 'Subnet') { | ||||
| 15368 | 0 | 0 | return "$obj->{ip},$obj->{mask}"; | ||||
| 15369 | } | ||||||
| 15370 | elsif ($type eq 'Interface') { | ||||||
| 15371 | 36 | 93 | return("$obj->{ip}," . 0xffffffff); ## no critic (MismatchedOperators) | ||||
| 15372 | } | ||||||
| 15373 | else { | ||||||
| 15374 | 0 | 0 | internal_err(); | ||||
| 15375 | } | ||||||
| 15376 | } | ||||||
| 15377 | |||||||
| 15378 | sub distribute_rules { | ||||||
| 15379 | 24 | 0 | 24 | my ($rules, $in_intf, $out_intf) = @_; | |||
| 15380 | 24 | 25 | for my $rule (@$rules) { | ||||
| 15381 | 36 | 45 | distribute_rule($rule, $in_intf, $out_intf); | ||||
| 15382 | } | ||||||
| 15383 | 24 | 40 | return; | ||||
| 15384 | } | ||||||
| 15385 | |||||||
| 15386 | sub create_general_permit_rules { | ||||||
| 15387 | 9 | 0 | 10 | my ($protocols, $context) = @_; | |||
| 15388 | 9 | 9 | my @rules; | ||||
| 15389 | 9 | 13 | for my $prt (@$protocols) { | ||||
| 15390 | |||||||
| 15391 | # Prevent modification of original array. | ||||||
| 15392 | 13 | 12 | my $prt = $prt; | ||||
| 15393 | 13 | 34 | if (ref $prt eq 'ARRAY') { | ||||
| 15394 | 2 | 3 | (my $src_range, $prt, my $orig_prt) = @$prt; | ||||
| 15395 | } | ||||||
| 15396 | elsif (my $main_prt = $prt->{main}) { | ||||||
| 15397 | 2 | 2 | $prt = $main_prt; | ||||
| 15398 | } | ||||||
| 15399 | 13 | 26 | my $rule = { | ||||
| 15400 | src => $network_00, | ||||||
| 15401 | dst => $network_00, | ||||||
| 15402 | prt => $prt, | ||||||
| 15403 | }; | ||||||
| 15404 | 13 | 20 | push @rules, $rule; | ||||
| 15405 | } | ||||||
| 15406 | 9 | 17 | return \@rules; | ||||
| 15407 | } | ||||||
| 15408 | |||||||
| 15409 | sub distribute_general_permit { | ||||||
| 15410 | 155 | 0 | 184 | for my $router (@managed_routers) { | |||
| 15411 | 257 | 549 | my $general_permit = $router->{general_permit} or next; | ||||
| 15412 | 9 | 26 | my $rules = | ||||
| 15413 | create_general_permit_rules( | ||||||
| 15414 | $general_permit, "general_permit of $router->{name}"); | ||||||
| 15415 | 9 | 12 | my $need_protect = $router->{need_protect}; | ||||
| 15416 | 9 9 | 10 10 | for my $in_intf (@{ $router->{interfaces} }) { | ||||
| 15417 | 16 | 29 | next if $in_intf->{main_interface}; | ||||
| 15418 | |||||||
| 15419 | # At VPN hub, don't permit any -> any, but only traffic | ||||||
| 15420 | # from each encrypted network. | ||||||
| 15421 | 16 | 25 | if ($in_intf->{is_hub}) { | ||||
| 15422 | 3 | 3 | my $id_rules = $in_intf->{id_rules}; | ||||
| 15423 | 3 5 | 6 7 | for my $src ( | ||||
| 15424 | $id_rules | ||||||
| 15425 | 1 | 2 | ? map({ $_->{src} } values %$id_rules) | ||||
| 15426 | : @{ $in_intf->{peer_networks} } | ||||||
| 15427 | ) | ||||||
| 15428 | { | ||||||
| 15429 | 7 | 8 | for my $rule (@$rules) { | ||||
| 15430 | 7 | 13 | my $rule = {%$rule}; | ||||
| 15431 | 7 | 8 | $rule->{src} = $src; | ||||
| 15432 | 7 7 | 7 7 | for my $out_intf (@{ $router->{interfaces} }) { | ||||
| 15433 | 14 | 45 | next if $out_intf eq $in_intf; | ||||
| 15434 | 7 | 12 | next if $out_intf->{ip} eq 'tunnel'; | ||||
| 15435 | |||||||
| 15436 | # Traffic traverses the device. | ||||||
| 15437 | # Traffic for the device itself isn't needed | ||||||
| 15438 | # at VPN hub. | ||||||
| 15439 | 7 | 7 | distribute_rule($rule, $in_intf, $out_intf); | ||||
| 15440 | } | ||||||
| 15441 | } | ||||||
| 15442 | } | ||||||
| 15443 | } | ||||||
| 15444 | else { | ||||||
| 15445 | 13 13 | 12 18 | for my $out_intf (@{ $router->{interfaces} }) { | ||||
| 15446 | 26 | 55 | next if $out_intf eq $in_intf; | ||||
| 15447 | |||||||
| 15448 | # For IOS and NX-OS print this rule only | ||||||
| 15449 | # once at interface filter rules below | ||||||
| 15450 | # (for incoming ACL). | ||||||
| 15451 | 13 | 20 | if ($need_protect) { | ||||
| 15452 | 2 | 3 | my $out_hw = $out_intf->{hardware}; | ||||
| 15453 | |||||||
| 15454 | # For interface with outgoing ACLs | ||||||
| 15455 | # we need to add the rule. | ||||||
| 15456 | # distribute_rule would add rule to incoming, | ||||||
| 15457 | # hence we add rule directly to outgoing rules. | ||||||
| 15458 | 2 | 3 | if ($out_hw->{need_out_acl}) { | ||||
| 15459 | 0 0 | 0 0 | push @{ $out_hw->{out_rules} }, @$rules; | ||||
| 15460 | } | ||||||
| 15461 | 2 | 3 | next; | ||||
| 15462 | } | ||||||
| 15463 | 11 | 17 | next if $out_intf->{main_interface}; | ||||
| 15464 | |||||||
| 15465 | # Traffic traverses the device. | ||||||
| 15466 | 11 | 16 | distribute_rules($rules, $in_intf, $out_intf); | ||||
| 15467 | } | ||||||
| 15468 | |||||||
| 15469 | # Traffic for the device itself. | ||||||
| 15470 | 13 | 24 | next if $in_intf->{ip} eq 'bridged'; | ||||
| 15471 | 13 | 18 | distribute_rules($rules, $in_intf, undef); | ||||
| 15472 | } | ||||||
| 15473 | } | ||||||
| 15474 | } | ||||||
| 15475 | 155 | 150 | return; | ||||
| 15476 | } | ||||||
| 15477 | |||||||
| 15478 | sub sort_rules_by_prio { | ||||||
| 15479 | |||||||
| 15480 | # Sort rules by reverse priority of protocol. | ||||||
| 15481 | # This should be done late to get all auxiliary rules processed. | ||||||
| 15482 | 155 | 0 | 209 | for my $type ('deny', 'supernet', 'permit') { | |||
| 15483 | 534 | 3709 | $expanded_rules{$type} = [ | ||||
| 15484 | sort { | ||||||
| 15485 | 465 | 977 | ($b->{prt}->{prio} || 0) <=> ($a->{prt}->{prio} || 0) | ||||
| 15486 | || ($a->{prt}->{prio} || 0) | ||||||
| 15487 | && ( cmp_address($a->{src}) cmp cmp_address($b->{src}) | ||||||
| 15488 | || cmp_address($a->{dst}) cmp cmp_address($b->{dst})) | ||||||
| 15489 | 465 | 343 | } @{ $expanded_rules{$type} } | ||||
| 15490 | ]; | ||||||
| 15491 | } | ||||||
| 15492 | 155 | 156 | return; | ||||
| 15493 | } | ||||||
| 15494 | |||||||
| 15495 | sub rules_distribution { | ||||||
| 15496 | 208 | 0 | 248 | return if fast_mode(); | |||
| 15497 | 155 | 234 | progress('Distributing rules'); | ||||
| 15498 | |||||||
| 15499 | 155 | 216 | sort_rules_by_prio(); | ||||
| 15500 | |||||||
| 15501 | # Deny rules | ||||||
| 15502 | 155 155 | 141 234 | for my $rule (@{ $expanded_rules{deny} }) { | ||||
| 15503 | 0 | 0 | next if $rule->{deleted}; | ||||
| 15504 | 0 | 0 | path_walk($rule, \&distribute_rule); | ||||
| 15505 | } | ||||||
| 15506 | |||||||
| 15507 | # Handle global permit after deny rules. | ||||||
| 15508 | 155 | 254 | distribute_general_permit(); | ||||
| 15509 | |||||||
| 15510 | # Permit rules | ||||||
| 15511 | 155 155 155 | 132 184 209 | for my $rule (@{ $expanded_rules{supernet} }, @{ $expanded_rules{permit} }) | ||||
| 15512 | { | ||||||
| 15513 | next | ||||||
| 15514 | 474 | 767 | if $rule->{deleted} | ||||
| 15515 | and | ||||||
| 15516 | (not $rule->{managed_intf} or $rule->{deleted}->{managed_intf}); | ||||||
| 15517 | 458 | 677 | path_walk($rule, \&distribute_rule, 'Router'); | ||||
| 15518 | } | ||||||
| 15519 | |||||||
| 15520 | 155 | 252 | add_router_acls(); | ||||
| 15521 | 155 | 269 | prepare_local_optimization(); | ||||
| 15522 | |||||||
| 15523 | # No longer needed, free some memory. | ||||||
| 15524 | 155 | 279 | %expanded_rules = (); | ||||
| 15525 | 155 | 207 | %obj2path = (); | ||||
| 15526 | 155 | 162 | %key2obj = (); | ||||
| 15527 | 155 | 130 | return; | ||||
| 15528 | } | ||||||
| 15529 | |||||||
| 15530 | ############################################################################## | ||||||
| 15531 | # ACL Generation | ||||||
| 15532 | ############################################################################## | ||||||
| 15533 | |||||||
| 15534 | # Returns [ ip, mask ] pair | ||||||
| 15535 | sub address { | ||||||
| 15536 | 2817 | 0 | 2315 | my ($obj, $no_nat_set) = @_; | |||
| 15537 | 2817 | 2586 | my $type = ref $obj; | ||||
| 15538 | 2817 | 3848 | if ($type eq 'Network') { | ||||
| 15539 | 2168 | 2382 | $obj = get_nat_network($obj, $no_nat_set); | ||||
| 15540 | |||||||
| 15541 | # ToDo: Is it OK to permit a dynamic address as destination? | ||||||
| 15542 | 2168 | 2917 | if ($obj->{ip} eq 'unnumbered') { | ||||
| 15543 | 0 | 0 | internal_err("Unexpected unnumbered $obj->{name}"); | ||||
| 15544 | } | ||||||
| 15545 | else { | ||||||
| 15546 | 2168 | 4488 | return [ $obj->{ip}, $obj->{mask} ]; | ||||
| 15547 | } | ||||||
| 15548 | } | ||||||
| 15549 | elsif ($type eq 'Subnet') { | ||||||
| 15550 | 96 | 141 | my $network = get_nat_network($obj->{network}, $no_nat_set); | ||||
| 15551 | 96 | 146 | if (my $nat_tag = $network->{dynamic}) { | ||||
| 15552 | 2 | 5 | if (my $ip = $obj->{nat}->{$nat_tag}) { | ||||
| 15553 | |||||||
| 15554 | # Single static NAT IP for this host. | ||||||
| 15555 | 2 | 4 | return [ $ip, 0xffffffff ]; | ||||
| 15556 | } | ||||||
| 15557 | else { | ||||||
| 15558 | |||||||
| 15559 | # This has been converted to the whole network before, | ||||||
| 15560 | # and hence should never happen. | ||||||
| 15561 | 0 | 0 | return [ $network->{ip}, $network->{mask} ]; | ||||
| 15562 | } | ||||||
| 15563 | } | ||||||
| 15564 | else { | ||||||
| 15565 | |||||||
| 15566 | # Take higher bits from network NAT, lower bits from original IP. | ||||||
| 15567 | # This works with and without NAT. | ||||||
| 15568 | 94 | 158 | my $ip = | ||||
| 15569 | $network->{ip} | $obj->{ip} & complement_32bit $network->{mask}; | ||||||
| 15570 | 94 | 210 | return [ $ip, $obj->{mask} ]; | ||||
| 15571 | } | ||||||
| 15572 | } | ||||||
| 15573 | elsif ($type eq 'Interface') { | ||||||
| 15574 | 516 | 1099 | if ($obj->{ip} =~ /^(unnumbered|short)$/) { | ||||
| 15575 | 0 | 0 | internal_err("Unexpected $obj->{ip} $obj->{name}"); | ||||
| 15576 | } | ||||||
| 15577 | |||||||
| 15578 | 516 | 673 | my $network = get_nat_network($obj->{network}, $no_nat_set); | ||||
| 15579 | |||||||
| 15580 | 516 | 1054 | if ($obj->{ip} eq 'negotiated') { | ||||
| 15581 | 2 2 | 1 4 | my ($network_ip, $network_mask) = @{$network}{ 'ip', 'mask' }; | ||||
| 15582 | 2 | 4 | return [ $network_ip, $network_mask ]; | ||||
| 15583 | } | ||||||
| 15584 | elsif (my $nat_tag = $network->{dynamic}) { | ||||||
| 15585 | 4 | 12 | if (my $ip = $obj->{nat}->{$nat_tag}) { | ||||
| 15586 | |||||||
| 15587 | # Single static NAT IP for this interface. | ||||||
| 15588 | 3 | 7 | return [ $ip, 0xffffffff ]; | ||||
| 15589 | } | ||||||
| 15590 | else { | ||||||
| 15591 | |||||||
| 15592 | # Should never happen. | ||||||
| 15593 | # aborts with error in mark_dynamic_nat_rules. | ||||||
| 15594 | 1 | 3 | return [ $network->{ip}, $network->{mask} ]; | ||||
| 15595 | } | ||||||
| 15596 | } | ||||||
| 15597 | else { | ||||||
| 15598 | |||||||
| 15599 | # Take higher bits from network NAT, lower bits from original IP. | ||||||
| 15600 | # This works with and without NAT. | ||||||
| 15601 | 510 | 785 | my $ip = | ||||
| 15602 | $network->{ip} | $obj->{ip} & complement_32bit $network->{mask}; | ||||||
| 15603 | 510 | 1048 | return [ $ip, 0xffffffff ]; | ||||
| 15604 | } | ||||||
| 15605 | } | ||||||
| 15606 | elsif ($type eq 'Objectgroup') { | ||||||
| 15607 | 37 | 56 | return $obj; | ||||
| 15608 | } | ||||||
| 15609 | else { | ||||||
| 15610 | 0 | 0 | my $type = ref $obj; | ||||
| 15611 | 0 | 0 | internal_err("Unexpected object of type '$type'"); | ||||
| 15612 | } | ||||||
| 15613 | } | ||||||
| 15614 | |||||||
| 15615 | # Given an IP and mask, return its address in Cisco syntax. | ||||||
| 15616 | sub cisco_acl_addr { | ||||||
| 15617 | 2086 | 0 | 1753 | my ($pair, $model) = @_; | |||
| 15618 | 2086 | 2240 | if (is_objectgroup $pair) { | ||||
| 15619 | 37 | 68 | my $keyword = | ||||
| 15620 | $model->{filter} eq 'NX-OS' ? 'addrgroup' : 'object-group'; | ||||||
| 15621 | 37 | 94 | return "$keyword $pair->{name}"; | ||||
| 15622 | } | ||||||
| 15623 | elsif ($pair->[0] == 0) { | ||||||
| 15624 | 1199 | 1722 | return "any"; | ||||
| 15625 | } | ||||||
| 15626 | elsif ($model->{use_prefix}) { | ||||||
| 15627 | 51 | 62 | return full_prefix_code($pair); | ||||
| 15628 | } | ||||||
| 15629 | else { | ||||||
| 15630 | 799 | 795 | my ($ip, $mask) = @$pair; | ||||
| 15631 | 799 | 889 | my $ip_code = print_ip($ip); | ||||
| 15632 | 799 | 1083 | if ($mask == 0xffffffff) { | ||||
| 15633 | 289 | 564 | return "host $ip_code"; | ||||
| 15634 | } | ||||||
| 15635 | else { | ||||||
| 15636 | 510 | 947 | $mask = complement_32bit($mask) if $model->{inversed_acl_mask}; | ||||
| 15637 | 510 | 559 | my $mask_code = print_ip($mask); | ||||
| 15638 | 510 | 1149 | return "$ip_code $mask_code"; | ||||
| 15639 | } | ||||||
| 15640 | } | ||||||
| 15641 | } | ||||||
| 15642 | |||||||
| 15643 | sub ios_route_code { | ||||||
| 15644 | 99 | 0 | 97 | my ($pair) = @_; | |||
| 15645 | 99 | 120 | my ($ip, $mask) = @$pair; | ||||
| 15646 | 99 | 118 | my $ip_code = print_ip($ip); | ||||
| 15647 | 99 | 130 | my $mask_code = print_ip($mask); | ||||
| 15648 | 99 | 198 | return "$ip_code $mask_code"; | ||||
| 15649 | } | ||||||
| 15650 | |||||||
| 15651 | # Given an IP and mask, return its address | ||||||
| 15652 | # as "x.x.x.x/x" or "x.x.x.x" if prefix == 32. | ||||||
| 15653 | sub prefix_code { | ||||||
| 15654 | 163 | 0 | 149 | my ($pair) = @_; | |||
| 15655 | 163 | 157 | my ($ip, $mask) = @$pair; | ||||
| 15656 | 163 | 234 | my $ip_code = print_ip($ip); | ||||
| 15657 | 163 | 1102 | my $prefix_code = mask2prefix($mask); | ||||
| 15658 | 163 | 463 | return $prefix_code == 32 ? $ip_code : "$ip_code/$prefix_code"; | ||||
| 15659 | } | ||||||
| 15660 | |||||||
| 15661 | sub full_prefix_code { | ||||||
| 15662 | 69 | 0 | 65 | my ($pair) = @_; | |||
| 15663 | 69 | 73 | my ($ip, $mask) = @$pair; | ||||
| 15664 | 69 | 79 | my $ip_code = print_ip($ip); | ||||
| 15665 | 69 | 84 | my $prefix_code = mask2prefix($mask); | ||||
| 15666 | 69 | 163 | return "$ip_code/$prefix_code"; | ||||
| 15667 | } | ||||||
| 15668 | |||||||
| 15669 | # Returns 3 values for building a Cisco ACL: | ||||||
| 15670 | # permit <val1> <src> <val2> <dst> <val3> | ||||||
| 15671 | sub cisco_prt_code { | ||||||
| 15672 | 995 | 0 | 916 | my ($src_range, $prt, $model) = @_; | |||
| 15673 | 995 | 1038 | my $proto = $prt->{proto}; | ||||
| 15674 | |||||||
| 15675 | 995 | 1667 | if ($proto eq 'ip') { | ||||
| 15676 | 709 | 1127 | return ('ip', undef, undef); | ||||
| 15677 | } | ||||||
| 15678 | elsif ($proto eq 'tcp' or $proto eq 'udp') { | ||||||
| 15679 | my $port_code = sub { | ||||||
| 15680 | 266 | 251 | my ($range_obj) = @_; | ||||
| 15681 | 266 266 | 217 462 | my ($v1, $v2) = @{ $range_obj->{range} }; | ||||
| 15682 | 266 | 526 | if ($v1 == $v2) { | ||||
| 15683 | 213 | 451 | return ("eq $v1"); | ||||
| 15684 | } | ||||||
| 15685 | elsif ($v1 == 1 and $v2 == 65535) { | ||||||
| 15686 | 44 | 61 | return (undef); | ||||
| 15687 | } | ||||||
| 15688 | elsif ($v2 == 65535) { | ||||||
| 15689 | 0 | 0 | return 'gt ' . ($v1 - 1); | ||||
| 15690 | } | ||||||
| 15691 | elsif ($v1 == 1) { | ||||||
| 15692 | 0 | 0 | return 'lt ' . ($v2 + 1); | ||||
| 15693 | } | ||||||
| 15694 | else { | ||||||
| 15695 | 9 | 28 | return ("range $v1 $v2"); | ||||
| 15696 | } | ||||||
| 15697 | 253 | 811 | }; | ||||
| 15698 | 253 | 1265 | my $dst_prt = $port_code->($prt); | ||||
| 15699 | 253 | 461 | if (my $established = $prt->{established}) { | ||||
| 15700 | 33 | 48 | if (defined $dst_prt) { | ||||
| 15701 | 0 | 0 | $dst_prt .= ' established'; | ||||
| 15702 | } | ||||||
| 15703 | else { | ||||||
| 15704 | 33 | 41 | $dst_prt = 'established'; | ||||
| 15705 | } | ||||||
| 15706 | } | ||||||
| 15707 | 253 | 372 | my $src_prt = $src_range && $port_code->($src_range); | ||||
| 15708 | 253 | 1310 | return ($proto, $src_prt, $dst_prt); | ||||
| 15709 | } | ||||||
| 15710 | elsif ($proto eq 'icmp') { | ||||||
| 15711 | 28 | 47 | if (defined(my $type = $prt->{type})) { | ||||
| 15712 | 24 | 42 | if (defined(my $code = $prt->{code})) { | ||||
| 15713 | 0 | 0 | if ($model->{no_filter_icmp_code}) { | ||||
| 15714 | |||||||
| 15715 | # PIX can't handle the ICMP code field. | ||||||
| 15716 | # If we try to permit e.g. "port unreachable", | ||||||
| 15717 | # "unreachable any" could pass the PIX. | ||||||
| 15718 | 0 | 0 | return ($proto, undef, $type); | ||||
| 15719 | } | ||||||
| 15720 | else { | ||||||
| 15721 | 0 | 0 | return ($proto, undef, "$type $code"); | ||||
| 15722 | } | ||||||
| 15723 | } | ||||||
| 15724 | else { | ||||||
| 15725 | 24 | 61 | return ($proto, undef, $type); | ||||
| 15726 | } | ||||||
| 15727 | } | ||||||
| 15728 | else { | ||||||
| 15729 | 4 | 9 | return ($proto, undef, undef); | ||||
| 15730 | } | ||||||
| 15731 | } | ||||||
| 15732 | else { | ||||||
| 15733 | 5 | 10 | return ($proto, undef, undef); | ||||
| 15734 | } | ||||||
| 15735 | } | ||||||
| 15736 | |||||||
| 15737 | # Returns iptables code for filtering a protocol. | ||||||
| 15738 | sub iptables_prt_code { | ||||||
| 15739 | 89 | 0 | 79 | my ($src_range, $prt) = @_; | |||
| 15740 | 89 | 91 | my $proto = $prt->{proto}; | ||||
| 15741 | |||||||
| 15742 | 89 | 270 | if ($proto eq 'ip') { | ||||
| 15743 | 0 | 0 | return ''; | ||||
| 15744 | } | ||||||
| 15745 | elsif ($proto eq 'tcp' or $proto eq 'udp') { | ||||||
| 15746 | my $port_code = sub { | ||||||
| 15747 | 54 | 50 | my ($range_obj) = @_; | ||||
| 15748 | 54 54 | 44 94 | my ($v1, $v2) = @{ $range_obj->{range} }; | ||||
| 15749 | 54 | 141 | if ($v1 == $v2) { | ||||
| 15750 | 26 | 38 | return $v1; | ||||
| 15751 | } | ||||||
| 15752 | elsif ($v1 == 1 and $v2 == 65535) { | ||||||
| 15753 | 9 | 16 | return ''; | ||||
| 15754 | } | ||||||
| 15755 | elsif ($v2 == 65535) { | ||||||
| 15756 | 0 | 0 | return "$v1:"; | ||||
| 15757 | } | ||||||
| 15758 | elsif ($v1 == 1) { | ||||||
| 15759 | 0 | 0 | return ":$v2"; | ||||
| 15760 | } | ||||||
| 15761 | else { | ||||||
| 15762 | 19 | 44 | return "$v1:$v2"; | ||||
| 15763 | } | ||||||
| 15764 | 51 | 153 | }; | ||||
| 15765 | 51 | 67 | my $result = "-p $proto"; | ||||
| 15766 | 51 | 76 | my $sport = $src_range && $port_code->($src_range); | ||||
| 15767 | 51 | 68 | $result .= " --sport $sport" if $sport; | ||||
| 15768 | 51 | 62 | my $dport = $port_code->($prt); | ||||
| 15769 | 51 | 122 | $result .= " --dport $dport" if $dport; | ||||
| 15770 | 51 | 237 | return $result; | ||||
| 15771 | } | ||||||
| 15772 | elsif ($proto eq 'icmp') { | ||||||
| 15773 | 30 | 48 | if (defined(my $type = $prt->{type})) { | ||||
| 15774 | 22 | 28 | if (defined(my $code = $prt->{code})) { | ||||
| 15775 | 0 | 0 | return "-p $proto --icmp-type $type/$code"; | ||||
| 15776 | } | ||||||
| 15777 | else { | ||||||
| 15778 | 22 | 57 | return "-p $proto --icmp-type $type"; | ||||
| 15779 | } | ||||||
| 15780 | } | ||||||
| 15781 | else { | ||||||
| 15782 | 8 | 18 | return "-p $proto"; | ||||
| 15783 | } | ||||||
| 15784 | } | ||||||
| 15785 | else { | ||||||
| 15786 | 8 | 18 | return "-p $proto"; | ||||
| 15787 | } | ||||||
| 15788 | } | ||||||
| 15789 | |||||||
| 15790 | sub cisco_acl_line { | ||||||
| 15791 | 506 | 0 | 584 | my ($router, $rules_aref, $no_nat_set, $prefix) = @_; | |||
| 15792 | 506 | 479 | my $model = $router->{model}; | ||||
| 15793 | 506 | 479 | my $filter_type = $model->{filter}; | ||||
| 15794 | 506 | 2623 | $filter_type =~ /^(:?IOS|NX-OS|PIX|ACE)$/ | ||||
| 15795 | or internal_err("Unknown filter_type $filter_type"); | ||||||
| 15796 | 506 | 424 | my $numbered = 10; | ||||
| 15797 | 506 | 491 | my $active_log = $router->{log}; | ||||
| 15798 | 506 | 562 | for my $rule (@$rules_aref) { | ||||
| 15799 | 995 | 1518 | print "$model->{comment_char} " . print_rule($rule) . "\n" | ||||
| 15800 | if $config{comment_acls}; | ||||||
| 15801 | 995 | 1681 | my ($deny, $src, $dst, $src_range, $prt) = | ||||
| 15802 | 995 | 816 | @{$rule}{qw(deny src dst src_range prt)}; | ||||
| 15803 | 995 | 1284 | my $action = $deny ? 'deny' : 'permit'; | ||||
| 15804 | 995 | 1276 | my $spair = address($src, $no_nat_set); | ||||
| 15805 | 995 | 1198 | my $dpair = address($dst, $no_nat_set); | ||||
| 15806 | |||||||
| 15807 | 995 | 1302 | my ($proto_code, $src_port_code, $dst_port_code) = | ||||
| 15808 | cisco_prt_code($src_range, $prt, $model); | ||||||
| 15809 | 995 | 2043 | my $result = "$prefix $action $proto_code"; | ||||
| 15810 | 995 | 1346 | $result .= ' ' . cisco_acl_addr($spair, $model); | ||||
| 15811 | 995 | 1669 | $result .= " $src_port_code" if defined $src_port_code; | ||||
| 15812 | 995 | 1136 | $result .= ' ' . cisco_acl_addr($dpair, $model); | ||||
| 15813 | 995 | 1686 | $result .= " $dst_port_code" if defined $dst_port_code; | ||||
| 15814 | |||||||
| 15815 | # Find code for logging. | ||||||
| 15816 | 995 | 729 | my $log_code; | ||||
| 15817 | 995 | 1676 | if ($active_log && (my $log = $rule->{log})) { | ||||
| 15818 | 20 | 22 | for my $tag (@$log) { | ||||
| 15819 | 20 | 33 | if (exists $active_log->{$tag}) { | ||||
| 15820 | 18 | 30 | if (my $modifier = $active_log->{$tag}) { | ||||
| 15821 | 16 | 21 | my $normalized = $model->{log_modifiers}->{$modifier}; | ||||
| 15822 | 16 | 21 | if ($normalized eq ':subst') { | ||||
| 15823 | 5 | 7 | $log_code = $modifier; | ||||
| 15824 | } | ||||||
| 15825 | else { | ||||||
| 15826 | 11 | 16 | $log_code = "log $normalized"; | ||||
| 15827 | } | ||||||
| 15828 | } | ||||||
| 15829 | else { | ||||||
| 15830 | 2 | 3 | $log_code = 'log'; | ||||
| 15831 | } | ||||||
| 15832 | |||||||
| 15833 | # Take first of possibly several matching tags. | ||||||
| 15834 | 18 | 20 | last; | ||||
| 15835 | } | ||||||
| 15836 | } | ||||||
| 15837 | } | ||||||
| 15838 | 995 | 2712 | if ($log_code) { | ||||
| 15839 | 18 | 27 | $result .= " $log_code"; | ||||
| 15840 | } | ||||||
| 15841 | elsif ($router->{log_deny} && $deny) { | ||||||
| 15842 | 2 | 3 | $result .= " log"; | ||||
| 15843 | } | ||||||
| 15844 | |||||||
| 15845 | # Add line numbers. | ||||||
| 15846 | 995 | 1356 | if ($filter_type eq 'NX-OS') { | ||||
| 15847 | 62 | 83 | $result = " $numbered$result"; | ||||
| 15848 | 62 | 63 | $numbered += 10; | ||||
| 15849 | } | ||||||
| 15850 | 995 | 2885 | print "$result\n"; | ||||
| 15851 | } | ||||||
| 15852 | 506 | 648 | return; | ||||
| 15853 | } | ||||||
| 15854 | |||||||
| 15855 | my $min_object_group_size = 2; | ||||||
| 15856 | |||||||
| 15857 | sub find_object_groups { | ||||||
| 15858 | 250 | 0 | 241 | my ($router, $hardware) = @_; | |||
| 15859 | 250 | 249 | my $model = $router->{model}; | ||||
| 15860 | 250 | 246 | my $filter_type = $model->{filter}; | ||||
| 15861 | 250 | 221 | my $active_log = $router->{log}; | ||||
| 15862 | 250 | 333 | my $keyword = $filter_type eq 'NX-OS' | ||||
| 15863 | ? 'object-group ip address' | ||||||
| 15864 | : 'object-group network'; | ||||||
| 15865 | |||||||
| 15866 | # Find identical groups of same size. | ||||||
| 15867 | 250 | 627 | my $size2first2group_hash = ($router->{size2first2group_hash} ||= {}); | ||||
| 15868 | 250 | 725 | $router->{vrf_shared_data}->{obj_group_counter} ||= 0; | ||||
| 15869 | |||||||
| 15870 | # Leave 'intf_rules' untouched, because they are handled | ||||||
| 15871 | # indivually for ASA, PIX. | ||||||
| 15872 | # NX-OS needs them indivually when optimizing need_protect. | ||||||
| 15873 | 250 | 280 | for my $rule_type ('rules', 'out_rules') { | ||||
| 15874 | 500 | 862 | next if not $hardware->{$rule_type}; | ||||
| 15875 | |||||||
| 15876 | # Find object-groups in src / dst of rules. | ||||||
| 15877 | 499 | 494 | for my $this ('src', 'dst') { | ||||
| 15878 | 998 | 1378 | my $that = $this eq 'src' ? 'dst' : 'src'; | ||||
| 15879 | 998 | 717 | my %group_rule_tree; | ||||
| 15880 | |||||||
| 15881 | # Find groups of rules with identical | ||||||
| 15882 | # deny, src_range, prt, log, src/dst and different dst/src. | ||||||
| 15883 | 998 998 | 734 1385 | for my $rule (@{ $hardware->{$rule_type} }) { | ||||
| 15884 | 549 | 1293 | my $deny = $rule->{deny} || ''; | ||||
| 15885 | 549 | 502 | my $that = $rule->{$that}; | ||||
| 15886 | 549 | 490 | my $this = $rule->{$this}; | ||||
| 15887 | 549 | 1202 | my $src_range = $rule->{src_range} || ''; | ||||
| 15888 | 549 | 454 | my $prt = $rule->{prt}; | ||||
| 15889 | 549 | 1258 | my $key = "$deny,$that,$src_range,$prt"; | ||||
| 15890 | 549 | 828 | if (my $log = $rule->{log}) { | ||||
| 15891 | 30 | 29 | for my $tag (@$log) { | ||||
| 15892 | 30 | 60 | if (defined(my $type = $active_log->{$tag})) { | ||||
| 15893 | 28 | 30 | $key .= ",$type"; | ||||
| 15894 | 28 | 31 | last; | ||||
| 15895 | } | ||||||
| 15896 | } | ||||||
| 15897 | } | ||||||
| 15898 | 549 | 1585 | $group_rule_tree{$key}->{$this} = $rule; | ||||
| 15899 | } | ||||||
| 15900 | |||||||
| 15901 | # Find groups >= $min_object_group_size, | ||||||
| 15902 | # mark rules belonging to one group, | ||||||
| 15903 | # put groups into an array / hash. | ||||||
| 15904 | 998 | 1479 | for my $href (values %group_rule_tree) { | ||||
| 15905 | |||||||
| 15906 | # $href is {dst/src => rule, ...} | ||||||
| 15907 | 453 | 536 | my $size = keys %$href; | ||||
| 15908 | 453 | 840 | if ($size >= $min_object_group_size) { | ||||
| 15909 | 46 | 93 | my $glue = { | ||||
| 15910 | |||||||
| 15911 | # Indicator, that no further rules need | ||||||
| 15912 | # to be processed. | ||||||
| 15913 | active => 0, | ||||||
| 15914 | |||||||
| 15915 | # NAT map for address calculation. | ||||||
| 15916 | no_nat_set => $hardware->{no_nat_set}, | ||||||
| 15917 | |||||||
| 15918 | # object-ref => rule, ... | ||||||
| 15919 | hash => $href | ||||||
| 15920 | }; | ||||||
| 15921 | |||||||
| 15922 | # All this rules have identical | ||||||
| 15923 | # deny, src_range, prt and dst/src | ||||||
| 15924 | # and shall be replaced by a single new rule | ||||||
| 15925 | # referencing an object group. | ||||||
| 15926 | 46 | 63 | for my $rule (values %$href) { | ||||
| 15927 | 142 | 196 | $rule->{group_glue} = $glue; | ||||
| 15928 | } | ||||||
| 15929 | } | ||||||
| 15930 | } | ||||||
| 15931 | |||||||
| 15932 | my $calc_ip_mask_strings = sub { | ||||||
| 15933 | 25 | 27 | my ($keys, $no_nat_set) = @_; | ||||
| 15934 | 94 158 | 253 258 | return(map { join('/', @$_) } | ||||
| 15935 | 94 | 116 | sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } | ||||
| 15936 | 94 | 184 | map { address($_, $no_nat_set) } | ||||
| 15937 | 25 | 32 | map { $ref2obj{$_} || internal_err($_) } | ||||
| 15938 | @$keys); | ||||||
| 15939 | 998 | 2679 | }; | ||||
| 15940 | |||||||
| 15941 | my $build_group = sub { | ||||||
| 15942 | 24 | 21 | my ($ip_mask_strings) = @_; | ||||
| 15943 | 24 | 33 | my $counter = $router->{vrf_shared_data}->{obj_group_counter}++; | ||||
| 15944 | |||||||
| 15945 | 92 | 185 | my $group = new( | ||||
| 15946 | 'Objectgroup', | ||||||
| 15947 | name => "g$counter", | ||||||
| 15948 | elements => $ip_mask_strings, | ||||||
| 15949 | 24 | 46 | hash => { map { $_ => 1 } @$ip_mask_strings }, | ||||
| 15950 | ); | ||||||
| 15951 | |||||||
| 15952 | # Print object-group. | ||||||
| 15953 | 24 | 28 | my $numbered = 10; | ||||
| 15954 | 24 | 65 | print "$keyword $group->{name}\n"; | ||||
| 15955 | 24 | 29 | for my $ip_mask ( @$ip_mask_strings ) { | ||||
| 15956 | 92 | 190 | my $pair = [ split '/', $ip_mask ]; | ||||
| 15957 | |||||||
| 15958 | # Reject network with mask = 0 in group. | ||||||
| 15959 | # This occurs if optimization didn't work correctly. | ||||||
| 15960 | 92 | 187 | $pair->[1] == 0 and | ||||
| 15961 | internal_err("Unexpected object with mask 0", | ||||||
| 15962 | " in object-group of $router->{name}"); | ||||||
| 15963 | 92 | 123 | my $adr = cisco_acl_addr($pair, $model); | ||||
| 15964 | 92 | 182 | if ($filter_type eq 'NX-OS') { | ||||
| 15965 | 13 | 22 | print " $numbered $adr\n"; | ||||
| 15966 | 13 | 23 | $numbered += 10; | ||||
| 15967 | } | ||||||
| 15968 | elsif ($filter_type eq 'ACE') { | ||||||
| 15969 | 0 | 0 | print " $adr\n"; | ||||
| 15970 | } | ||||||
| 15971 | else { | ||||||
| 15972 | 79 | 201 | print " network-object $adr\n"; | ||||
| 15973 | } | ||||||
| 15974 | } | ||||||
| 15975 | 24 | 37 | return $group; | ||||
| 15976 | 998 | 2486 | }; | ||||
| 15977 | |||||||
| 15978 | # Find group with identical elements or define a new one. | ||||||
| 15979 | my $get_group = sub { | ||||||
| 15980 | 46 | 41 | my ($glue) = @_; | ||||
| 15981 | 46 | 42 | my $hash = $glue->{hash}; | ||||
| 15982 | 46 | 44 | my $no_nat_set = $glue->{no_nat_set}; | ||||
| 15983 | |||||||
| 15984 | # Keys are sorted by their internal address to get | ||||||
| 15985 | # some "first" element. | ||||||
| 15986 | # This element is useable for hashing, because addresses | ||||||
| 15987 | # are known to be fix during program execution. | ||||||
| 15988 | 46 | 134 | my @keys = sort keys %$hash; | ||||
| 15989 | 46 | 56 | my $first = $keys[0]; | ||||
| 15990 | 46 | 44 | my $size = @keys; | ||||
| 15991 | |||||||
| 15992 | # Find group with identical elements. | ||||||
| 15993 | 46 | 113 | HASH: | ||||
| 15994 | 46 | 40 | for my $group_hash | ||||
| 15995 | (@{ $size2first2group_hash->{$size}->{$first} }) | ||||||
| 15996 | { | ||||||
| 15997 | 22 | 22 | my $href = $group_hash->{hash}; | ||||
| 15998 | |||||||
| 15999 | # Check elements for equality. | ||||||
| 16000 | 22 | 20 | for my $key (@keys) { | ||||
| 16001 | 50 | 97 | $href->{$key} or next HASH; | ||||
| 16002 | } | ||||||
| 16003 | |||||||
| 16004 | # Found $group_hash with matching elements. | ||||||
| 16005 | # Check for existing group in current NAT domain. | ||||||
| 16006 | 22 | 22 | my $nat2group = $group_hash->{nat2group}; | ||||
| 16007 | 22 | 53 | if (my $group = $nat2group->{$no_nat_set}) { | ||||
| 16008 | 21 | 43 | return $group; | ||||
| 16009 | } | ||||||
| 16010 | |||||||
| 16011 | 1 | 11 | my @ip_mask_strings = | ||||
| 16012 | $calc_ip_mask_strings->(\@keys, $no_nat_set); | ||||||
| 16013 | |||||||
| 16014 | # Check for matching group in other NAT domains. | ||||||
| 16015 | GROUP: | ||||||
| 16016 | 1 | 3 | for my $group (values %$nat2group) { | ||||
| 16017 | 1 | 1 | my $href = $group->{hash}; | ||||
| 16018 | |||||||
| 16019 | # Check NATed addresses for equality. | ||||||
| 16020 | 1 | 2 | for my $key (@ip_mask_strings) { | ||||
| 16021 | 2 | 5 | $href->{$key} or next GROUP; | ||||
| 16022 | } | ||||||
| 16023 | |||||||
| 16024 | # Found matching group. | ||||||
| 16025 | 1 | 1 | $nat2group->{$no_nat_set} = $group; | ||||
| 16026 | 1 | 3 | return $group; | ||||
| 16027 | } | ||||||
| 16028 | |||||||
| 16029 | # No group found, build new group. | ||||||
| 16030 | 0 | 0 | my $group = $build_group->(\@ip_mask_strings); | ||||
| 16031 | 0 | 0 | $nat2group->{$no_nat_set} = $group; | ||||
| 16032 | 0 | 0 | return $group; | ||||
| 16033 | } | ||||||
| 16034 | |||||||
| 16035 | # No group hash found, build new group hash with new group. | ||||||
| 16036 | 24 | 44 | my @ip_mask_strings = | ||||
| 16037 | $calc_ip_mask_strings->(\@keys, $no_nat_set); | ||||||
| 16038 | 24 | 69 | my $group = $build_group->(\@ip_mask_strings); | ||||
| 16039 | 24 | 64 | my $group_hash = { | ||||
| 16040 | hash => $hash, | ||||||
| 16041 | nat2group => { $no_nat_set => $group }, | ||||||
| 16042 | }; | ||||||
| 16043 | 24 24 | 22 44 | push(@{ $size2first2group_hash->{$size}->{$first} }, | ||||
| 16044 | $group_hash); | ||||||
| 16045 | 24 | 50 | return $group; | ||||
| 16046 | 998 | 2646 | }; | ||||
| 16047 | |||||||
| 16048 | # Build new list of rules using object groups. | ||||||
| 16049 | 998 | 756 | my @new_rules; | ||||
| 16050 | 998 998 | 747 1340 | for my $rule (@{ $hardware->{$rule_type} }) { | ||||
| 16051 | |||||||
| 16052 | # Remove tag, otherwise call to find_object_groups | ||||||
| 16053 | # for another router would become confused. | ||||||
| 16054 | 549 | 904 | if (my $glue = delete $rule->{group_glue}) { | ||||
| 16055 | |||||||
| 16056 | # debug(print_rule $rule); | ||||||
| 16057 | 142 | 209 | if ($glue->{active}) { | ||||
| 16058 | |||||||
| 16059 | # debug(" deleted: $glue->{group}->{name}"); | ||||||
| 16060 | 96 | 135 | next; | ||||
| 16061 | } | ||||||
| 16062 | 46 | 72 | my $group = $get_group->($glue); | ||||
| 16063 | |||||||
| 16064 | # debug(" generated: $group->{name}"); | ||||||
| 16065 | # # Only needed when debugging. | ||||||
| 16066 | # $glue->{group} = $group; | ||||||
| 16067 | |||||||
| 16068 | 46 | 51 | $glue->{active} = 1; | ||||
| 16069 | 46 | 83 | my ($deny, $srcdst, $src_range, $prt, $log) = | ||||
| 16070 | 46 | 41 | @{$rule}{'deny', $that, 'src_range', 'prt', 'log'}; | ||||
| 16071 | 46 | 95 | $rule = { | ||||
| 16072 | $that => $srcdst, | ||||||
| 16073 | $this => $group, | ||||||
| 16074 | prt => $prt | ||||||
| 16075 | }; | ||||||
| 16076 | 46 | 80 | $rule->{deny} = $deny if $deny; | ||||
| 16077 | 46 | 65 | $rule->{src_range} = $src_range if $src_range; | ||||
| 16078 | 46 | 73 | $rule->{log} = $log if $log; | ||||
| 16079 | } | ||||||
| 16080 | 453 | 637 | push @new_rules, $rule; | ||||
| 16081 | } | ||||||
| 16082 | 998 | 13777 | $hardware->{$rule_type} = \@new_rules; | ||||
| 16083 | } | ||||||
| 16084 | } | ||||||
| 16085 | 250 | 404 | return; | ||||
| 16086 | } | ||||||
| 16087 | |||||||
| 16088 | # Handle iptables. | ||||||
| 16089 | # | ||||||
| 16090 | sub debug_bintree { | ||||||
| 16091 | 0 | 0 | 0 | my ($tree, $depth) = @_; | |||
| 16092 | 0 | 0 | $depth ||= ''; | ||||
| 16093 | 0 | 0 | my $ip = print_ip $tree->{ip}; | ||||
| 16094 | 0 | 0 | my $mask = print_ip $tree->{mask}; | ||||
| 16095 | 0 | 0 | my $subtree = $tree->{subtree} ? 'subtree' : ''; | ||||
| 16096 | |||||||
| 16097 | # debug($depth, " $ip/$mask $subtree"); | ||||||
| 16098 | # debug_bintree($tree->{lo}, "${depth}l") if $tree->{lo}; | ||||||
| 16099 | # debug_bintree($tree->{hi}, "${depth}h") if $tree->{hi}; | ||||||
| 16100 | 0 | 0 | return; | ||||
| 16101 | } | ||||||
| 16102 | |||||||
| 16103 | # Nodes are reverse sorted before being added to bintree. | ||||||
| 16104 | # Redundant nodes are discarded while inserting. | ||||||
| 16105 | # A node with value of sub-tree S is discarded, | ||||||
| 16106 | # if some parent node already has sub-tree S. | ||||||
| 16107 | sub add_bintree; | ||||||
| 16108 | |||||||
| 16109 | sub add_bintree { | ||||||
| 16110 | 28 | 0 | 29 | my ($tree, $node) = @_; | |||
| 16111 | 28 28 | 23 45 | my ($tree_ip, $tree_mask) = @{$tree}{qw(ip mask)}; | ||||
| 16112 | 28 28 | 23 41 | my ($node_ip, $node_mask) = @{$node}{qw(ip mask)}; | ||||
| 16113 | 28 | 22 | my $result; | ||||
| 16114 | |||||||
| 16115 | # The case where new node is larger than root node will never | ||||||
| 16116 | # occur, because nodes are sorted before being added. | ||||||
| 16117 | |||||||
| 16118 | 28 | 105 | if ($tree_mask < $node_mask && match_ip($node_ip, $tree_ip, $tree_mask)) { | ||||
| 16119 | |||||||
| 16120 | # Optimization for this special case: | ||||||
| 16121 | # Root of tree has attribute {subtree} which is identical to | ||||||
| 16122 | # attribute {subtree} of current node. | ||||||
| 16123 | # Node is known to be less than root node. | ||||||
| 16124 | # Hence node together with its subtree can be discarded | ||||||
| 16125 | # because it is redundant compared to root node. | ||||||
| 16126 | # ToDo: | ||||||
| 16127 | # If this optimization had been done before merge_subtrees, | ||||||
| 16128 | # it could have merged more subtrees. | ||||||
| 16129 | 6 | 34 | if ( not $tree->{subtree} | ||||
| 16130 | or not $node->{subtree} | ||||||
| 16131 | or $tree->{subtree} ne $node->{subtree}) | ||||||
| 16132 | { | ||||||
| 16133 | 5 | 8 | my $mask = ($tree_mask >> 1) | 0x80000000; | ||||
| 16134 | 5 | 8 | my $branch = match_ip($node_ip, $tree_ip, $mask) ? 'lo' : 'hi'; | ||||
| 16135 | 5 | 12 | if (my $subtree = $tree->{$branch}) { | ||||
| 16136 | 4 | 11 | $tree->{$branch} = add_bintree $subtree, $node; | ||||
| 16137 | } | ||||||
| 16138 | else { | ||||||
| 16139 | 1 | 2 | $tree->{$branch} = $node; | ||||
| 16140 | } | ||||||
| 16141 | } | ||||||
| 16142 | 6 | 6 | $result = $tree; | ||||
| 16143 | } | ||||||
| 16144 | |||||||
| 16145 | # Different nodes with identical IP address. | ||||||
| 16146 | # This shouldn't occur, because different nodes have already | ||||||
| 16147 | # been converted to an unique object: | ||||||
| 16148 | # 1. Different interfaces of redundancy protocols like VRRP or HSRP. | ||||||
| 16149 | # 2. Dynamic NAT of different networks or hosts to a single address | ||||||
| 16150 | # or range. | ||||||
| 16151 | elsif ($tree_mask == $node_mask && $tree_ip == $node_ip) { | ||||||
| 16152 | 0 | 0 | my $sub1 = $tree->{subtree} || ''; | ||||
| 16153 | 0 | 0 | my $sub2 = $node->{subtree} || ''; | ||||
| 16154 | 0 | 0 | if ($sub1 ne $sub2) { | ||||
| 16155 | 0 | 0 | my $ip = print_ip $tree_ip; | ||||
| 16156 | 0 | 0 | my $mask = print_ip $tree_mask; | ||||
| 16157 | 0 | 0 | internal_err("Inconsistent rules for iptables for $ip/$mask"); | ||||
| 16158 | } | ||||||
| 16159 | 0 | 0 | $result = $tree; | ||||
| 16160 | } | ||||||
| 16161 | |||||||
| 16162 | # Create common root for tree and node. | ||||||
| 16163 | else { | ||||||
| 16164 | 22 | 23 | while (1) { | ||||
| 16165 | 221 | 163 | $tree_mask = ($tree_mask & 0x7fffffff) << 1; | ||||
| 16166 | 221 | 296 | last if ($node_ip & $tree_mask) == ($tree_ip & $tree_mask); | ||||
| 16167 | } | ||||||
| 16168 | 22 | 34 | $result = new( | ||||
| 16169 | 'Network', | ||||||
| 16170 | ip => ($node_ip & $tree_mask), | ||||||
| 16171 | mask => $tree_mask | ||||||
| 16172 | ); | ||||||
| 16173 | 22 22 | 37 39 | @{$result}{qw(lo hi)} = | ||||
| 16174 | $node_ip < $tree_ip ? ($node, $tree) : ($tree, $node); | ||||||
| 16175 | } | ||||||
| 16176 | |||||||
| 16177 | # Merge adjacent sub-networks. | ||||||
| 16178 | 28 | 56 | MERGE: | ||||
| 16179 | { | ||||||
| 16180 | 28 | 22 | $result->{subtree} and last; | ||||
| 16181 | 26 | 40 | my $lo = $result->{lo} or last; | ||||
| 16182 | 26 | 42 | my $hi = $result->{hi} or last; | ||||
| 16183 | 26 | 27 | my $mask = ($result->{mask} >> 1) | 0x80000000; | ||||
| 16184 | 26 | 52 | $lo->{mask} == $mask or last; | ||||
| 16185 | 3 | 10 | $hi->{mask} == $mask or last; | ||||
| 16186 | 3 | 13 | $lo->{subtree} and $hi->{subtree} or last; | ||||
| 16187 | 3 | 8 | $lo->{subtree} eq $hi->{subtree} or last; | ||||
| 16188 | |||||||
| 16189 | 1 | 1 | for my $key (qw(lo hi)) { | ||||
| 16190 | 2 | 3 | $lo->{$key} and last MERGE; | ||||
| 16191 | 2 | 5 | $hi->{$key} and last MERGE; | ||||
| 16192 | } | ||||||
| 16193 | |||||||
| 16194 | # debug('Merged: ', print_ip $lo->{ip},' ', | ||||||
| 16195 | # print_ip $hi->{ip},'/',print_ip $hi->{mask}); | ||||||
| 16196 | 1 | 2 | $result->{subtree} = $lo->{subtree}; | ||||
| 16197 | 1 | 2 | delete $result->{lo}; | ||||
| 16198 | 1 | 1 | delete $result->{hi}; | ||||
| 16199 | } | ||||||
| 16200 | 28 | 69 | return $result; | ||||
| 16201 | } | ||||||
| 16202 | |||||||
| 16203 | # Build a binary tree for src/dst objects. | ||||||
| 16204 | sub gen_addr_bintree { | ||||||
| 16205 | 108 | 0 | 104 | my ($elements, $tree, $no_nat_set) = @_; | |||
| 16206 | |||||||
| 16207 | # Sort in reverse order by mask and then by IP. | ||||||
| 16208 | 28 | 78 | my @nodes = | ||||
| 16209 | 132 | 163 | sort { $b->{mask} <=> $a->{mask} || $b->{ip} <=> $a->{ip} } | ||||
| 16210 | map { | ||||||
| 16211 | 108 132 | 106 95 | my ($ip, $mask) = @{ address($_, $no_nat_set) }; | ||||
| 16212 | |||||||
| 16213 | # The tree's node is a simplified network object with | ||||||
| 16214 | # missing attribute 'name' and extra 'subtree'. | ||||||
| 16215 | 132 | 294 | new( | ||||
| 16216 | 'Network', | ||||||
| 16217 | ip => $ip, | ||||||
| 16218 | mask => $mask, | ||||||
| 16219 | subtree => $tree->{$_} | ||||||
| 16220 | ) | ||||||
| 16221 | } @$elements; | ||||||
| 16222 | 108 | 98 | my $bintree = pop @nodes; | ||||
| 16223 | 108 | 200 | while (my $next = pop @nodes) { | ||||
| 16224 | 24 | 34 | $bintree = add_bintree $bintree, $next; | ||||
| 16225 | } | ||||||
| 16226 | |||||||
| 16227 | # Add attribute {noop} to node which doesn't add any test to | ||||||
| 16228 | # generated rule. | ||||||
| 16229 | 108 | 178 | $bintree->{noop} = 1 if $bintree->{mask} == 0; | ||||
| 16230 | |||||||
| 16231 | # debug_bintree($bintree); | ||||||
| 16232 | 108 | 143 | return $bintree; | ||||
| 16233 | } | ||||||
| 16234 | |||||||
| 16235 | # Build a tree for src-range/prt objects. Sub-trees for tcp and udp | ||||||
| 16236 | # will be binary trees. Nodes have attributes {proto}, {range}, | ||||||
| 16237 | # {type}, {code} like protocols (but without {name}). | ||||||
| 16238 | # Additional attributes for building the tree: | ||||||
| 16239 | # For tcp and udp: | ||||||
| 16240 | # {lo}, {hi} for sub-ranges of current node. | ||||||
| 16241 | # For other protocols: | ||||||
| 16242 | # {seq} an array of ordered nodes for sub protocols of current node. | ||||||
| 16243 | # Elements of {lo} and {hi} or elements of {seq} are guaranteed to be | ||||||
| 16244 | # disjoint. | ||||||
| 16245 | # Additional attribute {subtree} is set with corresponding subtree of | ||||||
| 16246 | # protocol object if current node comes from a rule and wasn't inserted | ||||||
| 16247 | # for optimization. | ||||||
| 16248 | sub gen_prt_bintree { | ||||||
| 16249 | 101 | 0 | 98 | my ($elements, $tree) = @_; | |||
| 16250 | |||||||
| 16251 | 101 | 80 | my $ip_prt; | ||||
| 16252 | my %top_prt; | ||||||
| 16253 | 0 | 0 | my %sub_prt; | ||||
| 16254 | |||||||
| 16255 | # Add all protocols directly below protocol 'ip' into hash %top_prt | ||||||
| 16256 | # grouped by protocol. Add protocols below top protocols or below | ||||||
| 16257 | # other protocols of current set of protocols to hash %sub_prt. | ||||||
| 16258 | PRT: | ||||||
| 16259 | 101 | 115 | for my $prt (@$elements) { | ||||
| 16260 | 131 | 134 | my $proto = $prt->{proto}; | ||||
| 16261 | 131 | 152 | if ($proto eq 'ip') { | ||||
| 16262 | 12 | 20 | $ip_prt = $prt; | ||||
| 16263 | } | ||||||
| 16264 | else { | ||||||
| 16265 | 119 | 103 | my $up = $prt->{up}; | ||||
| 16266 | |||||||
| 16267 | # Check if $prt is sub protocol of any other protocol of | ||||||
| 16268 | # current set. But handle direct sub protocols of 'ip' as | ||||||
| 16269 | # top protocols. | ||||||
| 16270 | 119 | 191 | while ($up->{up}) { | ||||
| 16271 | 61 | 117 | if (my $subtree = $tree->{$up}) { | ||||
| 16272 | |||||||
| 16273 | # Found sub protocol of current set. | ||||||
| 16274 | # Optimization: | ||||||
| 16275 | # Ignore the sub protocol if both protocols | ||||||
| 16276 | # have identical subtrees. | ||||||
| 16277 | # This happens for different objects having identical IP | ||||||
| 16278 | # from NAT or from redundant interfaces. | ||||||
| 16279 | 6 | 13 | if ($tree->{$prt} ne $subtree) { | ||||
| 16280 | 5 5 | 4 7 | push @{ $sub_prt{$up} }, $prt; | ||||
| 16281 | } | ||||||
| 16282 | 6 | 11 | next PRT; | ||||
| 16283 | } | ||||||
| 16284 | 55 | 106 | $up = $up->{up}; | ||||
| 16285 | } | ||||||
| 16286 | |||||||
| 16287 | # Not a sub protocol (except possibly of IP). | ||||||
| 16288 | 113 | 225 | my $key = $proto =~ /^\d+$/ ? 'proto' : $proto; | ||||
| 16289 | 113 113 | 97 269 | push @{ $top_prt{$key} }, $prt; | ||||
| 16290 | } | ||||||
| 16291 | } | ||||||
| 16292 | |||||||
| 16293 | # Collect subtrees for tcp, udp, proto and icmp. | ||||||
| 16294 | 101 | 93 | my @seq; | ||||
| 16295 | |||||||
| 16296 | # Build subtree of tcp and udp protocols. | ||||||
| 16297 | # | ||||||
| 16298 | # We need not to handle 'tcp established' because it is only used | ||||||
| 16299 | # for stateless routers, but iptables is stateful. | ||||||
| 16300 | my $gen_lohitrees; | ||||||
| 16301 | 0 | 0 | my $gen_rangetree; | ||||
| 16302 | $gen_lohitrees = sub { | ||||||
| 16303 | 143 | 161 | my ($prt_aref) = @_; | ||||
| 16304 | 143 | 230 | if (not $prt_aref) { | ||||
| 16305 | 65 | 102 | return (undef, undef); | ||||
| 16306 | } | ||||||
| 16307 | elsif (@$prt_aref == 1) { | ||||||
| 16308 | 69 | 56 | my $prt = $prt_aref->[0]; | ||||
| 16309 | 69 | 249 | my ($lo, $hi) = $gen_lohitrees->($sub_prt{$prt}); | ||||
| 16310 | 69 | 241 | my $node = { | ||||
| 16311 | proto => $prt->{proto}, | ||||||
| 16312 | range => $prt->{range}, | ||||||
| 16313 | subtree => $tree->{$prt}, | ||||||
| 16314 | lo => $lo, | ||||||
| 16315 | hi => $hi | ||||||
| 16316 | }; | ||||||
| 16317 | 69 | 118 | return ($node, undef); | ||||
| 16318 | } | ||||||
| 16319 | else { | ||||||
| 16320 | 9 | 22 | my @ranges = | ||||
| 16321 | 9 | 16 | sort { $a->{range}->[0] <=> $b->{range}->[0] } @$prt_aref; | ||||
| 16322 | |||||||
| 16323 | # Split array in two halves. | ||||||
| 16324 | 9 | 17 | my $mid = int($#ranges / 2); | ||||
| 16325 | 9 | 17 | my $left = [ @ranges[ 0 .. $mid ] ]; | ||||
| 16326 | 9 | 15 | my $right = [ @ranges[ $mid + 1 .. $#ranges ] ]; | ||||
| 16327 | 9 | 28 | return ($gen_rangetree->($left), $gen_rangetree->($right)); | ||||
| 16328 | } | ||||||
| 16329 | 101 | 388 | }; | ||||
| 16330 | $gen_rangetree = sub { | ||||||
| 16331 | 74 | 65 | my ($prt_aref) = @_; | ||||
| 16332 | 74 | 110 | my ($lo, $hi) = $gen_lohitrees->($prt_aref); | ||||
| 16333 | 74 | 159 | return $lo if not $hi; | ||||
| 16334 | 8 | 8 | my $proto = $lo->{proto}; | ||||
| 16335 | |||||||
| 16336 | # Take low port from lower tree and high port from high tree. | ||||||
| 16337 | 8 | 19 | my $range = [ $lo->{range}->[0], $hi->{range}->[1] ]; | ||||
| 16338 | |||||||
| 16339 | # Merge adjacent port ranges. | ||||||
| 16340 | 8 | 53 | if ( $lo->{range}->[1] + 1 == $hi->{range}->[0] | ||||
| 16341 | and $lo->{subtree} | ||||||
| 16342 | and $hi->{subtree} | ||||||
| 16343 | and $lo->{subtree} eq $hi->{subtree}) | ||||||
| 16344 | { | ||||||
| 16345 | 12 | 17 | my @hilo = | ||||
| 16346 | 3 | 6 | grep { defined $_ } $lo->{lo}, $lo->{hi}, $hi->{lo}, $hi->{hi}; | ||||
| 16347 | 3 | 8 | if (@hilo <= 2) { | ||||
| 16348 | |||||||
| 16349 | # debug("Merged: $lo->{range}->[0]-$lo->{range}->[1]", | ||||||
| 16350 | # " $hi->{range}->[0]-$hi->{range}->[1]"); | ||||||
| 16351 | 2 | 6 | my $node = { | ||||
| 16352 | proto => $proto, | ||||||
| 16353 | range => $range, | ||||||
| 16354 | subtree => $lo->{subtree} | ||||||
| 16355 | }; | ||||||
| 16356 | 2 | 4 | $node->{lo} = shift @hilo if @hilo; | ||||
| 16357 | 2 | 4 | $node->{hi} = shift @hilo if @hilo; | ||||
| 16358 | 2 | 8 | return $node; | ||||
| 16359 | } | ||||||
| 16360 | } | ||||||
| 16361 | return ( | ||||||
| 16362 | { | ||||||
| 16363 | 6 | 18 | proto => $proto, | ||||
| 16364 | range => $range, | ||||||
| 16365 | lo => $lo, | ||||||
| 16366 | hi => $hi | ||||||
| 16367 | } | ||||||
| 16368 | ); | ||||||
| 16369 | 101 | 284 | }; | ||||
| 16370 | 101 | 114 | for my $what (qw(tcp udp)) { | ||||
| 16371 | 202 | 392 | next if not $top_prt{$what}; | ||||
| 16372 | 56 | 87 | push @seq, $gen_rangetree->($top_prt{$what}); | ||||
| 16373 | } | ||||||
| 16374 | |||||||
| 16375 | # Add single nodes for numeric protocols. | ||||||
| 16376 | 101 | 173 | if (my $aref = $top_prt{proto}) { | ||||
| 16377 | 8 0 | 10 0 | for my $prt (sort { $a->{proto} <=> $b->{proto} } @$aref) { | ||||
| 16378 | 8 | 21 | my $node = { proto => $prt->{proto}, subtree => $tree->{$prt} }; | ||||
| 16379 | 8 | 12 | push @seq, $node; | ||||
| 16380 | } | ||||||
| 16381 | } | ||||||
| 16382 | |||||||
| 16383 | # Build subtree of icmp protocols. | ||||||
| 16384 | 101 | 156 | if (my $icmp_aref = $top_prt{icmp}) { | ||||
| 16385 | 37 | 28 | my %type2prt; | ||||
| 16386 | my $icmp_any; | ||||||
| 16387 | |||||||
| 16388 | # If one protocol is 'icmp any' it is the only top protocol, | ||||||
| 16389 | # all other icmp protocols are sub protocols. | ||||||
| 16390 | 37 | 69 | if (not defined $icmp_aref->[0]->{type}) { | ||||
| 16391 | 20 | 17 | $icmp_any = $icmp_aref->[0]; | ||||
| 16392 | 20 | 28 | $icmp_aref = $sub_prt{$icmp_any}; | ||||
| 16393 | } | ||||||
| 16394 | |||||||
| 16395 | # Process icmp protocols having defined type and possibly defined code. | ||||||
| 16396 | # Group protocols by type. | ||||||
| 16397 | 37 | 46 | for my $prt (@$icmp_aref) { | ||||
| 16398 | 21 | 23 | my $type = $prt->{type}; | ||||
| 16399 | 21 21 | 17 47 | push @{ $type2prt{$type} }, $prt; | ||||
| 16400 | } | ||||||
| 16401 | |||||||
| 16402 | # Parameter is array of icmp protocols all having | ||||||
| 16403 | # the same type and different but defined code. | ||||||
| 16404 | # Return reference to array of nodes sorted by code. | ||||||
| 16405 | my $gen_icmp_type_code_sorted = sub { | ||||||
| 16406 | 0 | 0 | my ($aref) = @_; | ||||
| 16407 | [ | ||||||
| 16408 | 0 | 0 | map { | ||||
| 16409 | 0 | 0 | { | ||||
| 16410 | proto => 'icmp', | ||||||
| 16411 | type => $_->{proto}, | ||||||
| 16412 | code => $_->{code}, | ||||||
| 16413 | subtree => $tree->{$_} | ||||||
| 16414 | } | ||||||
| 16415 | } | ||||||
| 16416 | 0 | 0 | sort { $a->{code} <=> $b->{code} } @$aref | ||||
| 16417 | ]; | ||||||
| 16418 | 37 | 105 | }; | ||||
| 16419 | |||||||
| 16420 | # For collecting subtrees of icmp subtree. | ||||||
| 16421 | 37 | 29 | my @seq2; | ||||
| 16422 | |||||||
| 16423 | # Process grouped icmp protocols having the same type. | ||||||
| 16424 | 37 4 | 71 10 | for my $type (sort { $a <=> $b } keys %type2prt) { | ||||
| 16425 | 21 | 21 | my $aref2 = $type2prt{$type}; | ||||
| 16426 | 21 | 17 | my $node2; | ||||
| 16427 | |||||||
| 16428 | # If there is more than one protocol, | ||||||
| 16429 | # all have same type and defined code. | ||||||
| 16430 | 21 | 31 | if (@$aref2 > 1) { | ||||
| 16431 | 0 | 0 | my $seq3 = $gen_icmp_type_code_sorted->($aref2); | ||||
| 16432 | |||||||
| 16433 | # Add a node 'icmp type any' as root. | ||||||
| 16434 | 0 | 0 | $node2 = { | ||||
| 16435 | proto => 'icmp', | ||||||
| 16436 | type => $type, | ||||||
| 16437 | seq => $seq3, | ||||||
| 16438 | }; | ||||||
| 16439 | } | ||||||
| 16440 | |||||||
| 16441 | # One protocol 'icmp type any'. | ||||||
| 16442 | else { | ||||||
| 16443 | 21 | 20 | my $prt = $aref2->[0]; | ||||
| 16444 | 21 | 61 | $node2 = { | ||||
| 16445 | proto => 'icmp', | ||||||
| 16446 | type => $type, | ||||||
| 16447 | subtree => $tree->{$prt} | ||||||
| 16448 | }; | ||||||
| 16449 | 21 | 47 | if (my $aref3 = $sub_prt{$prt}) { | ||||
| 16450 | 0 | 0 | $node2->{seq} = $gen_icmp_type_code_sorted->($aref3); | ||||
| 16451 | } | ||||||
| 16452 | } | ||||||
| 16453 | 21 | 38 | push @seq2, $node2; | ||||
| 16454 | } | ||||||
| 16455 | |||||||
| 16456 | # Add root node for icmp subtree. | ||||||
| 16457 | 37 | 35 | my $node; | ||||
| 16458 | 37 | 58 | if ($icmp_any) { | ||||
| 16459 | 20 | 57 | $node = { | ||||
| 16460 | proto => 'icmp', | ||||||
| 16461 | seq => \@seq2, | ||||||
| 16462 | subtree => $tree->{$icmp_any} | ||||||
| 16463 | }; | ||||||
| 16464 | } | ||||||
| 16465 | elsif (@seq2 > 1) { | ||||||
| 16466 | 4 | 8 | $node = { proto => 'icmp', seq => \@seq2 }; | ||||
| 16467 | } | ||||||
| 16468 | else { | ||||||
| 16469 | 13 | 12 | $node = $seq2[0]; | ||||
| 16470 | } | ||||||
| 16471 | 37 | 140 | push @seq, $node; | ||||
| 16472 | } | ||||||
| 16473 | |||||||
| 16474 | # Add root node for whole tree. | ||||||
| 16475 | 101 | 69 | my $bintree; | ||||
| 16476 | 101 | 173 | if ($ip_prt) { | ||||
| 16477 | 12 | 33 | $bintree = { | ||||
| 16478 | proto => 'ip', | ||||||
| 16479 | seq => \@seq, | ||||||
| 16480 | subtree => $tree->{$ip_prt} | ||||||
| 16481 | }; | ||||||
| 16482 | } | ||||||
| 16483 | elsif (@seq > 1) { | ||||||
| 16484 | 8 | 11 | $bintree = { proto => 'ip', seq => \@seq }; | ||||
| 16485 | } | ||||||
| 16486 | else { | ||||||
| 16487 | 81 | 74 | $bintree = $seq[0]; | ||||
| 16488 | } | ||||||
| 16489 | |||||||
| 16490 | # Add attribute {noop} to node which doesn't need any test in | ||||||
| 16491 | # generated chain. | ||||||
| 16492 | 101 | 185 | $bintree->{noop} = 1 if $bintree->{proto} eq 'ip'; | ||||
| 16493 | 101 | 200 | return $bintree; | ||||
| 16494 | } | ||||||
| 16495 | |||||||
| 16496 | my %ref_type = ( | ||||||
| 16497 | src => \%ref2obj, | ||||||
| 16498 | dst => \%ref2obj, | ||||||
| 16499 | src_prt => \%ref2prt, | ||||||
| 16500 | prt => \%ref2prt, | ||||||
| 16501 | ); | ||||||
| 16502 | |||||||
| 16503 | sub find_chains { | ||||||
| 16504 | 60 | 0 | 58 | my ($router, $hardware) = @_; | |||
| 16505 | |||||||
| 16506 | # For generating names of chains. | ||||||
| 16507 | # Initialize if called first time. | ||||||
| 16508 | 60 | 162 | $router->{vrf_shared_data}->{chain_counter} ||= 1; | ||||
| 16509 | |||||||
| 16510 | 60 | 56 | my $no_nat_set = $hardware->{no_nat_set}; | ||||
| 16511 | 60 | 47 | my $io_rules_hash = $hardware->{io_rules}; | ||||
| 16512 | 60 22 | 129 46 | my @rule_arefs = map { $io_rules_hash->{$_} } sort keys %$io_rules_hash; | ||||
| 16513 | 60 | 59 | my $intf_rules = $hardware->{intf_rules}; | ||||
| 16514 | 60 | 97 | push @rule_arefs, $intf_rules if $intf_rules; | ||||
| 16515 | |||||||
| 16516 | 60 | 67 | for my $rules (@rule_arefs) { | ||||
| 16517 | |||||||
| 16518 | # Change rules to allow optimization of objects having | ||||||
| 16519 | # identical IP adress. | ||||||
| 16520 | # This is crucial for correct operation of sub add_bintree. | ||||||
| 16521 | # Otherwise internal_err("Inconsistent rules for iptables") | ||||||
| 16522 | # would be triggered. | ||||||
| 16523 | 43 | 44 | for my $rule (@$rules) { | ||||
| 16524 | |||||||
| 16525 | # Restore {action} attribute in $rule, so we can handle | ||||||
| 16526 | # all properties of a rule in unified manner. | ||||||
| 16527 | # {src_range} attribute is unset for value $prt_ip. | ||||||
| 16528 | # This needs to be set here, but only for iptables. | ||||||
| 16529 | # Hence use new attribute {src_prt}. | ||||||
| 16530 | # $rule needs not to be copied: | ||||||
| 16531 | # - other device types will ignore this attributes, | ||||||
| 16532 | # - other linux devices will reuse them. | ||||||
| 16533 | 104 | 147 | if (!$rule->{action}) { | ||||
| 16534 | 91 | 151 | $rule->{action} = $rule->{deny} ? 'deny' : 'permit'; | ||||
| 16535 | 91 | 84 | my $src_prt = $rule->{src_range}; | ||||
| 16536 | 91 | 124 | if (not $src_prt) { | ||||
| 16537 | 91 | 100 | my $proto = $rule->{prt}->{proto}; | ||||
| 16538 | |||||||
| 16539 | # Specify protocols tcp, udp, icmp in | ||||||
| 16540 | # {src_prt}, to get more efficient chains. | ||||||
| 16541 | 91 | 158 | $src_prt = $proto eq 'tcp' ? $prt_tcp->{dst_range} | ||||
| 16542 | : $proto eq 'udp' ? $prt_udp->{dst_range} | ||||||
| 16543 | : $proto eq 'icmp' ? $prt_icmp | ||||||
| 16544 | : $prt_ip; | ||||||
| 16545 | } | ||||||
| 16546 | 91 | 116 | $rule->{src_prt} = $src_prt; | ||||
| 16547 | } | ||||||
| 16548 | |||||||
| 16549 | 104 | 79 | my $copied; | ||||
| 16550 | 104 | 96 | for my $what (qw(src dst)) { | ||||
| 16551 | 208 | 206 | my $orig = my $obj = $rule->{$what}; | ||||
| 16552 | |||||||
| 16553 | # Loopback interface is converted to loopback network, | ||||||
| 16554 | # because other networks may have this loopback network | ||||||
| 16555 | # as value in {is_identical}. | ||||||
| 16556 | 208 | 358 | if ($obj->{loopback} && (my $network = $obj->{network})) { | ||||
| 16557 | 8 | 38 | if (!($intf_rules && $rules eq $intf_rules && | ||||
| 16558 | $what eq 'dst')) | ||||||
| 16559 | { | ||||||
| 16560 | 2 | 3 | $obj = $network; | ||||
| 16561 | } | ||||||
| 16562 | } | ||||||
| 16563 | |||||||
| 16564 | # Identical networks from dynamic NAT and | ||||||
| 16565 | # from identical aggregates. | ||||||
| 16566 | 208 | 391 | if (my $identical = $obj->{is_identical}) { | ||||
| 16567 | 12 | 26 | if (my $other = $identical->{$no_nat_set}) { | ||||
| 16568 | 6 | 6 | $obj = $other; | ||||
| 16569 | } | ||||||
| 16570 | } | ||||||
| 16571 | |||||||
| 16572 | # Identical redundancy interfaces. | ||||||
| 16573 | elsif (my $aref = $obj->{redundancy_interfaces}) { | ||||||
| 16574 | 4 | 25 | if (!($intf_rules && $rules eq $intf_rules && | ||||
| 16575 | $what eq 'dst')) | ||||||
| 16576 | { | ||||||
| 16577 | 0 | 0 | $obj = $aref->[0]; | ||||
| 16578 | } | ||||||
| 16579 | } | ||||||
| 16580 | |||||||
| 16581 | 208 | 539 | $obj eq $orig and next; | ||||
| 16582 | |||||||
| 16583 | # Don't change rules of devices in other NAT domain | ||||||
| 16584 | # where we may have other {is_identical} relation. | ||||||
| 16585 | 8 | 36 | $rule = { %$rule } if !$copied++; | ||||
| 16586 | 8 | 22 | $rule->{$what} = $obj; | ||||
| 16587 | } | ||||||
| 16588 | } | ||||||
| 16589 | |||||||
| 16590 | 43 | 38 | my %cache; | ||||
| 16591 | |||||||
| 16592 | my $print_tree; | ||||||
| 16593 | $print_tree = sub { | ||||||
| 16594 | 0 | 0 | my ($tree, $order, $depth) = @_; | ||||
| 16595 | 0 | 0 | my $key = $order->[$depth]; | ||||
| 16596 | 0 | 0 | my $ref2x = $ref_type{$key}; | ||||
| 16597 | 0 0 | 0 0 | my @elements = map { $ref2x->{$_} } keys %$tree; | ||||
| 16598 | 0 | 0 | for my $elem (@elements) { | ||||
| 16599 | |||||||
| 16600 | # debug(' ' x $depth, "$elem->{name}"); | ||||||
| 16601 | 0 | 0 | if ($depth < $#$order) { | ||||
| 16602 | 0 | 0 | $print_tree->($tree->{$elem}, $order, $depth + 1); | ||||
| 16603 | } | ||||||
| 16604 | } | ||||||
| 16605 | 43 | 152 | }; | ||||
| 16606 | |||||||
| 16607 | my $insert_bintree = sub { | ||||||
| 16608 | 209 | 190 | my ($tree, $order, $depth) = @_; | ||||
| 16609 | 209 | 210 | my $key = $order->[$depth]; | ||||
| 16610 | 209 | 196 | my $ref2x = $ref_type{$key}; | ||||
| 16611 | 209 263 | 1265 413 | my @elements = map { $ref2x->{$_} } keys %$tree; | ||||
| 16612 | |||||||
| 16613 | # Put prt/src/dst objects at the root of some subtree into a | ||||||
| 16614 | # (binary) tree. This is used later to convert subsequent tests | ||||||
| 16615 | # for ip/mask or port ranges into more efficient nested chains. | ||||||
| 16616 | 209 | 188 | my $bintree; | ||||
| 16617 | 209 | 378 | if ($ref2x eq \%ref2obj) { | ||||
| 16618 | 108 | 157 | $bintree = gen_addr_bintree(\@elements, $tree, $no_nat_set); | ||||
| 16619 | } | ||||||
| 16620 | else { # $ref2x eq \%ref2prt | ||||||
| 16621 | 101 | 139 | $bintree = gen_prt_bintree(\@elements, $tree); | ||||
| 16622 | } | ||||||
| 16623 | 209 | 715 | return $bintree; | ||||
| 16624 | 43 | 118 | }; | ||||
| 16625 | |||||||
| 16626 | # Used by $merge_subtrees1 to find identical subtrees. | ||||||
| 16627 | # Use hash for efficient lookup. | ||||||
| 16628 | 43 | 35 | my %depth2size2subtrees; | ||||
| 16629 | my %subtree2bintree; | ||||||
| 16630 | |||||||
| 16631 | # Find and merge identical subtrees. | ||||||
| 16632 | my $merge_subtrees1 = sub { | ||||||
| 16633 | 147 | 133 | my ($tree, $order, $depth) = @_; | ||||
| 16634 | |||||||
| 16635 | SUBTREE: | ||||||
| 16636 | 147 | 187 | for my $subtree (values %$tree) { | ||||
| 16637 | 174 | 268 | my @keys = keys %$subtree; | ||||
| 16638 | 174 | 177 | my $size = @keys; | ||||
| 16639 | |||||||
| 16640 | # Find subtree with identical keys and values; | ||||||
| 16641 | 174 | 377 | FIND: | ||||
| 16642 | 174 | 135 | for my $subtree2 (@{ $depth2size2subtrees{$depth}->{$size} }) { | ||||
| 16643 | 36 | 37 | for my $key (@keys) { | ||||
| 16644 | 43 | 124 | if (not $subtree2->{$key} | ||||
| 16645 | or $subtree2->{$key} ne $subtree->{$key}) | ||||||
| 16646 | { | ||||||
| 16647 | 28 | 50 | next FIND; | ||||
| 16648 | } | ||||||
| 16649 | } | ||||||
| 16650 | |||||||
| 16651 | # Substitute current subtree with found subtree. | ||||||
| 16652 | 8 | 13 | $subtree = $subtree2bintree{$subtree2}; | ||||
| 16653 | 8 | 25 | next SUBTREE; | ||||
| 16654 | |||||||
| 16655 | } | ||||||
| 16656 | |||||||
| 16657 | # Found a new subtree. | ||||||
| 16658 | 166 166 | 145 218 | push @{ $depth2size2subtrees{$depth}->{$size} }, $subtree; | ||||
| 16659 | 166 | 248 | $subtree = $subtree2bintree{$subtree} = | ||||
| 16660 | $insert_bintree->($subtree, $order, $depth + 1); | ||||||
| 16661 | } | ||||||
| 16662 | 43 | 125 | }; | ||||
| 16663 | |||||||
| 16664 | my $merge_subtrees = sub { | ||||||
| 16665 | 43 | 44 | my ($tree, $order) = @_; | ||||
| 16666 | |||||||
| 16667 | # Process leaf nodes first. | ||||||
| 16668 | 43 | 70 | for my $href (values %$tree) { | ||||
| 16669 | 50 | 68 | for my $href (values %$href) { | ||||
| 16670 | 54 | 74 | $merge_subtrees1->($href, $order, 2); | ||||
| 16671 | } | ||||||
| 16672 | } | ||||||
| 16673 | |||||||
| 16674 | # Process nodes next to leaf nodes. | ||||||
| 16675 | 43 | 64 | for my $href (values %$tree) { | ||||
| 16676 | 50 | 62 | $merge_subtrees1->($href, $order, 1); | ||||
| 16677 | } | ||||||
| 16678 | |||||||
| 16679 | # Process nodes next to root. | ||||||
| 16680 | 43 | 65 | $merge_subtrees1->($tree, $order, 0); | ||||
| 16681 | 43 | 67 | return $insert_bintree->($tree, $order, 0); | ||||
| 16682 | 43 | 111 | }; | ||||
| 16683 | |||||||
| 16684 | # Add new chain to current router. | ||||||
| 16685 | my $new_chain = sub { | ||||||
| 16686 | 36 | 34 | my ($rules) = @_; | ||||
| 16687 | 36 | 51 | my $counter = $router->{vrf_shared_data}->{chain_counter}++; | ||||
| 16688 | 36 | 85 | my $chain = new( | ||||
| 16689 | 'Chain', | ||||||
| 16690 | name => "c$counter", | ||||||
| 16691 | rules => $rules, | ||||||
| 16692 | ); | ||||||
| 16693 | 36 36 | 36 51 | push @{ $router->{chains} }, $chain; | ||||
| 16694 | 36 | 42 | $chain; | ||||
| 16695 | 43 | 97 | }; | ||||
| 16696 | |||||||
| 16697 | 43 | 35 | my $gen_chain; | ||||
| 16698 | $gen_chain = sub { | ||||||
| 16699 | 250 | 240 | my ($tree, $order, $depth) = @_; | ||||
| 16700 | 250 | 230 | my $key = $order->[$depth]; | ||||
| 16701 | 250 | 176 | my @rules; | ||||
| 16702 | |||||||
| 16703 | # We need the original value later. | ||||||
| 16704 | 250 | 182 | my $bintree = $tree; | ||||
| 16705 | 250 | 184 | while (1) { | ||||
| 16706 | 297 | 424 | my ($hi, $lo, $seq, $subtree) = | ||||
| 16707 | 297 | 226 | @{$bintree}{qw(hi lo seq subtree)}; | ||||
| 16708 | 297 | 528 | $seq = undef if $seq and not @$seq; | ||||
| 16709 | 297 | 383 | if (not $seq) { | ||||
| 16710 | 281 | 363 | push @$seq, $hi if $hi; | ||||
| 16711 | 281 | 370 | push @$seq, $lo if $lo; | ||||
| 16712 | } | ||||||
| 16713 | 297 | 386 | if ($subtree) { | ||||
| 16714 | |||||||
| 16715 | # if($order->[$depth+1]&& | ||||||
| 16716 | # $order->[$depth+1] =~ /^(src|dst)$/) { | ||||||
| 16717 | # debug($order->[$depth+1]); | ||||||
| 16718 | # debug_bintree($subtree); | ||||||
| 16719 | # } | ||||||
| 16720 | 258 | 273 | my $rules = $cache{$subtree}; | ||||
| 16721 | 258 | 328 | if (not $rules) { | ||||
| 16722 | 209 | 776 | $rules = | ||||
| 16723 | $depth + 1 >= @$order | ||||||
| 16724 | ? [ { action => $subtree } ] | ||||||
| 16725 | : $gen_chain->($subtree, $order, $depth + 1); | ||||||
| 16726 | 209 | 389 | if (@$rules > 1 and not $bintree->{noop}) { | ||||
| 16727 | 9 | 13 | my $chain = $new_chain->($rules); | ||||
| 16728 | 9 | 18 | $rules = [ { action => $chain, goto => 1 } ]; | ||||
| 16729 | } | ||||||
| 16730 | 209 | 350 | $cache{$subtree} = $rules; | ||||
| 16731 | } | ||||||
| 16732 | |||||||
| 16733 | 258 | 173 | my @add_keys; | ||||
| 16734 | |||||||
| 16735 | # Don't use "goto", if some tests for sub-nodes of | ||||||
| 16736 | # $subtree are following. | ||||||
| 16737 | 258 | 349 | push @add_keys, (goto => 0) if $seq; | ||||
| 16738 | 258 | 458 | push @add_keys, ($key => $bintree) if not $bintree->{noop}; | ||||
| 16739 | 258 | 305 | if (@add_keys) { | ||||
| 16740 | |||||||
| 16741 | # Create a copy of each rule because we must not change | ||||||
| 16742 | # the original cached rules. | ||||||
| 16743 | 239 | 819 | push @rules, map { | ||||
| 16744 | 239 | 238 | { (%$_, @add_keys) } | ||||
| 16745 | } @$rules; | ||||||
| 16746 | } | ||||||
| 16747 | else { | ||||||
| 16748 | 19 | 27 | push @rules, @$rules; | ||||
| 16749 | } | ||||||
| 16750 | } | ||||||
| 16751 | 297 | 469 | last if not $seq; | ||||
| 16752 | |||||||
| 16753 | # Take this value in next iteration. | ||||||
| 16754 | 47 | 39 | $bintree = pop @$seq; | ||||
| 16755 | |||||||
| 16756 | # Process remaining elements. | ||||||
| 16757 | 47 | 58 | for my $node (@$seq) { | ||||
| 16758 | 41 | 119 | my $rules = $gen_chain->($node, $order, $depth); | ||||
| 16759 | 41 | 102 | push @rules, @$rules; | ||||
| 16760 | } | ||||||
| 16761 | } | ||||||
| 16762 | 250 | 512 | if (@rules > 1 and not $tree->{noop}) { | ||||
| 16763 | |||||||
| 16764 | # Generate new chain. All elements of @seq are | ||||||
| 16765 | # known to be disjoint. If one element has matched | ||||||
| 16766 | # and branched to a chain, then the other elements | ||||||
| 16767 | # need not be tested again. This is implemented by | ||||||
| 16768 | # calling the chain using '-g' instead of the usual '-j'. | ||||||
| 16769 | 27 | 39 | my $chain = $new_chain->(\@rules); | ||||
| 16770 | 27 | 73 | return [ { action => $chain, goto => 1, $key => $tree } ]; | ||||
| 16771 | } | ||||||
| 16772 | else { | ||||||
| 16773 | 223 | 314 | return \@rules; | ||||
| 16774 | } | ||||||
| 16775 | 43 | 168 | }; | ||||
| 16776 | |||||||
| 16777 | # Build rule trees. Generate and process separate tree for | ||||||
| 16778 | # adjacent rules with same action. | ||||||
| 16779 | 43 | 37 | my @rule_trees; | ||||
| 16780 | my %tree2order; | ||||||
| 16781 | 43 | 149 | if ($rules and @$rules) { | ||||
| 16782 | 43 | 55 | my $prev_action = $rules->[0]->{action}; | ||||
| 16783 | |||||||
| 16784 | # Special rule as marker, that end of rules has been reached. | ||||||
| 16785 | 43 | 76 | push @$rules, { action => 0 }; | ||||
| 16786 | 43 | 42 | my $start = my $i = 0; | ||||
| 16787 | 43 | 42 | my $last = $#$rules; | ||||
| 16788 | 43 | 36 | my %count; | ||||
| 16789 | 43 | 35 | while (1) { | ||||
| 16790 | 147 | 115 | my $rule = $rules->[$i]; | ||||
| 16791 | 147 | 133 | my $action = $rule->{action}; | ||||
| 16792 | 147 | 187 | if ($action eq $prev_action) { | ||||
| 16793 | |||||||
| 16794 | # Count, which key has the largest number of | ||||||
| 16795 | # different values. | ||||||
| 16796 | 104 | 101 | for my $what (qw(src dst src_prt prt)) { | ||||
| 16797 | 416 | 736 | $count{$what}{ $rule->{$what} } = 1; | ||||
| 16798 | } | ||||||
| 16799 | 104 | 105 | $i++; | ||||
| 16800 | } | ||||||
| 16801 | else { | ||||||
| 16802 | |||||||
| 16803 | # Use key with smaller number of different values | ||||||
| 16804 | # first in rule tree. This gives smaller tree and | ||||||
| 16805 | # fewer tests in chains. | ||||||
| 16806 | 179 | 211 | my @test_order = | ||||
| 16807 | 43 179 179 | 76 140 259 | sort { keys %{ $count{$a} } <=> keys %{ $count{$b} } } | ||||
| 16808 | qw(src_prt dst prt src); | ||||||
| 16809 | 43 | 35 | my $rule_tree; | ||||
| 16810 | 43 | 46 | my $end = $i - 1; | ||||
| 16811 | 43 | 84 | for (my $j = $start ; $j <= $end ; $j++) { | ||||
| 16812 | 104 | 87 | my $rule = $rules->[$j]; | ||||
| 16813 | 104 | 176 | my ($action, $t1, $t2, $t3, $t4) = | ||||
| 16814 | 104 | 85 | @{$rule}{ 'action', @test_order }; | ||||
| 16815 | 104 | 427 | $rule_tree->{$t1}->{$t2}->{$t3}->{$t4} = $action; | ||||
| 16816 | } | ||||||
| 16817 | 43 | 44 | push @rule_trees, $rule_tree; | ||||
| 16818 | |||||||
| 16819 | # debug(join ', ', @test_order); | ||||||
| 16820 | 43 | 68 | $tree2order{$rule_tree} = \@test_order; | ||||
| 16821 | 43 | 98 | last if not $action; | ||||
| 16822 | 0 | 0 | $start = $i; | ||||
| 16823 | 0 | 0 | $prev_action = $action; | ||||
| 16824 | } | ||||||
| 16825 | } | ||||||
| 16826 | 43 | 194 | @$rules = (); | ||||
| 16827 | } | ||||||
| 16828 | |||||||
| 16829 | 43 | 81 | for (my $i = 0 ; $i < @rule_trees ; $i++) { | ||||
| 16830 | 43 | 41 | my $tree = $rule_trees[$i]; | ||||
| 16831 | 43 | 52 | my $order = $tree2order{$tree}; | ||||
| 16832 | |||||||
| 16833 | # $print_tree->($tree, $order, 0); | ||||||
| 16834 | 43 | 124 | $tree = $merge_subtrees->($tree, $order); | ||||
| 16835 | 43 | 67 | my $result = $gen_chain->($tree, $order, 0); | ||||
| 16836 | |||||||
| 16837 | # Goto must not be used in last rule of rule tree which is | ||||||
| 16838 | # not the last tree. | ||||||
| 16839 | 43 | 82 | if ($i != $#rule_trees) { | ||||
| 16840 | 0 | 0 | my $rule = $result->[-1]; | ||||
| 16841 | 0 | 0 | delete $rule->{goto}; | ||||
| 16842 | } | ||||||
| 16843 | |||||||
| 16844 | # Postprocess rules: Add missing attributes prt, src, dst | ||||||
| 16845 | # with no-op values. | ||||||
| 16846 | 43 | 56 | for my $rule (@$result) { | ||||
| 16847 | 53 | 114 | $rule->{src} ||= $network_00; | ||||
| 16848 | 53 | 95 | $rule->{dst} ||= $network_00; | ||||
| 16849 | 53 | 47 | my $prt = $rule->{prt}; | ||||
| 16850 | 53 | 50 | my $src_prt = $rule->{src_prt}; | ||||
| 16851 | 53 | 182 | if (not $prt and not $src_prt) { | ||||
| 16852 | 4 | 8 | $rule->{prt} = $prt_ip; | ||||
| 16853 | } | ||||||
| 16854 | elsif (not $prt) { | ||||||
| 16855 | 2 | 8 | $rule->{prt} = | ||||
| 16856 | $src_prt->{proto} eq 'tcp' ? $prt_tcp->{dst_range} | ||||||
| 16857 | : $src_prt->{proto} eq 'udp' ? $prt_udp->{dst_range} | ||||||
| 16858 | : $src_prt->{proto} eq 'icmp' ? $prt_icmp | ||||||
| 16859 | : $prt_ip; | ||||||
| 16860 | |||||||
| 16861 | # Restore {src_range} from {src_prt}, because | ||||||
| 16862 | # {src_range} is only used in find_chains. | ||||||
| 16863 | 2 | 6 | $rule->{src_range} = delete $rule->{src_prt} | ||||
| 16864 | } | ||||||
| 16865 | } | ||||||
| 16866 | 43 | 670 | push @$rules, @$result; | ||||
| 16867 | } | ||||||
| 16868 | } | ||||||
| 16869 | 60 | 101 | return; | ||||
| 16870 | } | ||||||
| 16871 | |||||||
| 16872 | # Print chains of iptables. | ||||||
| 16873 | # Objects have already been normalized to ip/mask pairs. | ||||||
| 16874 | # NAT has already been applied. | ||||||
| 16875 | sub print_chains { | ||||||
| 16876 | 34 | 0 | 34 | my ($router) = @_; | |||
| 16877 | |||||||
| 16878 | # Declare chain names. | ||||||
| 16879 | 34 34 | 32 53 | for my $chain (@{ $router->{chains} }) { | ||||
| 16880 | 36 | 35 | my $name = $chain->{name}; | ||||
| 16881 | 36 | 58 | print ":$name -\n"; | ||||
| 16882 | } | ||||||
| 16883 | |||||||
| 16884 | # Define chains. | ||||||
| 16885 | 34 34 | 33 45 | for my $chain (@{ $router->{chains} }) { | ||||
| 16886 | 36 | 36 | my $name = $chain->{name}; | ||||
| 16887 | 36 | 40 | my $prefix = "-A $name"; | ||||
| 16888 | |||||||
| 16889 | # my $steps = my $accept = my $deny = 0; | ||||||
| 16890 | 36 36 | 30 43 | for my $rule (@{ $chain->{rules} }) { | ||||
| 16891 | 75 | 76 | my $action = $rule->{action}; | ||||
| 16892 | 75 | 96 | my $action_code = | ||||
| 16893 | is_chain($action) ? $action->{name} | ||||||
| 16894 | : $action eq 'permit' ? 'ACCEPT' | ||||||
| 16895 | : 'droplog'; | ||||||
| 16896 | |||||||
| 16897 | # Calculate maximal number of matches if | ||||||
| 16898 | # - some rules matches (accept) or | ||||||
| 16899 | # - all rules don't match (deny). | ||||||
| 16900 | # $steps += 1; | ||||||
| 16901 | # if ($action eq 'permit') { | ||||||
| 16902 | # $accept = max($accept, $steps); | ||||||
| 16903 | # } | ||||||
| 16904 | # elsif ($action eq 'deny') { | ||||||
| 16905 | # $deny = max($deny, $steps); | ||||||
| 16906 | # } | ||||||
| 16907 | # elsif ($rule->{goto}) { | ||||||
| 16908 | # $accept = max($accept, $steps + $action->{a}); | ||||||
| 16909 | # } | ||||||
| 16910 | # else { | ||||||
| 16911 | # $accept = max($accept, $steps + $action->{a}); | ||||||
| 16912 | # $steps += $action->{d}; | ||||||
| 16913 | # } | ||||||
| 16914 | |||||||
| 16915 | 75 | 110 | my $jump = $rule->{goto} ? '-g' : '-j'; | ||||
| 16916 | 75 | 90 | my $result = "$jump $action_code"; | ||||
| 16917 | 75 | 121 | if (my $src = $rule->{src}) { | ||||
| 16918 | 42 42 | 37 69 | my $ip_mask = [ @{$src}{qw(ip mask)} ]; | ||||
| 16919 | 42 | 75 | if ($ip_mask->[1] != 0) { | ||||
| 16920 | 42 | 62 | $result .= ' -s ' . prefix_code($ip_mask); | ||||
| 16921 | } | ||||||
| 16922 | } | ||||||
| 16923 | 75 | 129 | if (my $dst = $rule->{dst}) { | ||||
| 16924 | 15 15 | 12 26 | my $ip_mask = [ @{$dst}{qw(ip mask)} ]; | ||||
| 16925 | 15 | 29 | if ($ip_mask->[1] != 0) { | ||||
| 16926 | 15 | 18 | $result .= ' -d ' . prefix_code($ip_mask); | ||||
| 16927 | } | ||||||
| 16928 | } | ||||||
| 16929 | ADD_PROTO: | ||||||
| 16930 | { | ||||||
| 16931 | 75 75 | 55 65 | my $src_prt = $rule->{src_prt}; | ||||
| 16932 | 75 | 63 | my $prt = $rule->{prt}; | ||||
| 16933 | 75 | 178 | last ADD_PROTO if not $src_prt and not $prt; | ||||
| 16934 | 40 | 124 | last ADD_PROTO if $prt and $prt->{proto} eq 'ip'; | ||||
| 16935 | 40 | 57 | if (not $prt) { | ||||
| 16936 | 2 | 4 | last ADD_PROTO if $src_prt->{proto} eq 'ip'; | ||||
| 16937 | 2 | 7 | $prt = | ||||
| 16938 | $src_prt->{proto} eq 'tcp' ? $prt_tcp->{dst_range} | ||||||
| 16939 | : $src_prt->{proto} eq 'udp' ? $prt_udp->{dst_range} | ||||||
| 16940 | : $src_prt->{proto} eq 'icmp' ? $prt_icmp | ||||||
| 16941 | : $prt_ip; | ||||||
| 16942 | } | ||||||
| 16943 | |||||||
| 16944 | # debug("c ",print_rule $rule) if not $src_range or not $prt; | ||||||
| 16945 | 40 | 52 | $result .= ' ' . iptables_prt_code($src_prt, $prt); | ||||
| 16946 | } | ||||||
| 16947 | 75 | 224 | print "$prefix $result\n"; | ||||
| 16948 | } | ||||||
| 16949 | |||||||
| 16950 | # $deny = max($deny, $steps); | ||||||
| 16951 | # $chain->{a} = $accept; | ||||||
| 16952 | # $chain->{d} = $deny; | ||||||
| 16953 | # print "# Max tests: Accept: $accept, Deny: $deny\n"; | ||||||
| 16954 | } | ||||||
| 16955 | |||||||
| 16956 | # Empty line as delimiter. | ||||||
| 16957 | 34 | 39 | print "\n"; | ||||
| 16958 | 34 | 31 | return; | ||||
| 16959 | } | ||||||
| 16960 | |||||||
| 16961 | # Find adjacent port ranges. | ||||||
| 16962 | sub join_ranges { | ||||||
| 16963 | 514 | 0 | 443 | my ($router, $hardware) = @_; | |||
| 16964 | 514 | 374 | my $changed; | ||||
| 16965 | 514 | 467 | my $active_log = $router->{log}; | ||||
| 16966 | 514 | 526 | for my $rules ('intf_rules', 'rules', 'out_rules') { | ||||
| 16967 | 1542 | 1366 | my %hash = (); | ||||
| 16968 | 1542 | 1985 | RULE: | ||||
| 16969 | 1542 | 1094 | for my $rule (@{ $hardware->{$rules} }) { | ||||
| 16970 | 592 | 826 | my ($deny, $src, $dst, $src_range, $prt) = | ||||
| 16971 | 592 | 484 | @{$rule}{qw(deny src dst src_range prt)}; | ||||
| 16972 | |||||||
| 16973 | # Only ranges which have a neighbor may be successfully optimized. | ||||||
| 16974 | # Currently only dst_ranges are handled. | ||||||
| 16975 | 592 | 1152 | $prt->{has_neighbor} or next; | ||||
| 16976 | |||||||
| 16977 | 90 | 199 | $deny ||= ''; | ||||
| 16978 | 90 | 188 | $src_range ||= ''; | ||||
| 16979 | 90 | 287 | $hash{$deny}->{$src}->{$dst}->{$src_range}->{$prt} = $rule; | ||||
| 16980 | } | ||||||
| 16981 | |||||||
| 16982 | # %hash is {deny => href, ...} | ||||||
| 16983 | 1542 | 2196 | for my $href (values %hash) { | ||||
| 16984 | |||||||
| 16985 | # $href is {src => href, ...} | ||||||
| 16986 | 24 | 39 | for my $href (values %$href) { | ||||
| 16987 | |||||||
| 16988 | # $href is {dst => href, ...} | ||||||
| 16989 | 36 | 45 | for my $href (values %$href) { | ||||
| 16990 | |||||||
| 16991 | # $href is {src_range => href, ...} | ||||||
| 16992 | 70 | 88 | for my $src_range_ref (keys %$href) { | ||||
| 16993 | 70 | 62 | my $href = $href->{$src_range_ref}; | ||||
| 16994 | |||||||
| 16995 | # Nothing to do if only a single rule. | ||||||
| 16996 | 70 | 191 | next if values %$href == 1; | ||||
| 16997 | |||||||
| 16998 | # Values of %$href are rules with identical | ||||||
| 16999 | # deny/src/dst/src_range and a TCP or UDP protocol. | ||||||
| 17000 | # | ||||||
| 17001 | # Collect rules with identical log type and | ||||||
| 17002 | # identical protocol. | ||||||
| 17003 | 12 | 11 | my %key2rules; | ||||
| 17004 | 12 | 17 | for my $rule (values %$href) { | ||||
| 17005 | 32 | 35 | my $key = $rule->{prt}->{proto}; | ||||
| 17006 | 32 | 51 | if (my $log = $rule->{log}) { | ||||
| 17007 | 14 | 13 | for my $tag (@$log) { | ||||
| 17008 | 14 | 30 | if (defined(my $type = $active_log->{$tag})) | ||||
| 17009 | { | ||||||
| 17010 | 10 | 11 | $key .= ",$type"; | ||||
| 17011 | 10 | 10 | last; | ||||
| 17012 | } | ||||||
| 17013 | } | ||||||
| 17014 | } | ||||||
| 17015 | 32 32 | 26 59 | push @{ $key2rules{$key} }, $rule; | ||||
| 17016 | } | ||||||
| 17017 | |||||||
| 17018 | 12 | 21 | for my $rules (values %key2rules) { | ||||
| 17019 | |||||||
| 17020 | # When sorting these rules by low port number, | ||||||
| 17021 | # rules with adjacent protocols will placed | ||||||
| 17022 | # side by side. There can't be overlaps, | ||||||
| 17023 | # because they have been split in function | ||||||
| 17024 | # 'order_ranges'. There can't be sub-ranges, | ||||||
| 17025 | # because they have been deleted as redundant | ||||||
| 17026 | # above. | ||||||
| 17027 | 14 | 35 | my @sorted = sort { | ||||
| 17028 | 19 | 29 | $a->{prt}->{range}->[0] | ||||
| 17029 | <=> | ||||||
| 17030 | $b->{prt}->{range}->[0] | ||||||
| 17031 | } @$rules; | ||||||
| 17032 | 19 | 50 | @sorted >= 2 or next; | ||||
| 17033 | 11 | 11 | my $i = 0; | ||||
| 17034 | 11 | 11 | my $rule_a = $sorted[$i]; | ||||
| 17035 | 11 11 | 10 19 | my ($a1, $a2) = @{ $rule_a->{prt}->{range} }; | ||||
| 17036 | 11 | 22 | while (++$i < @sorted) { | ||||
| 17037 | 13 | 17 | my $rule_b = $sorted[$i]; | ||||
| 17038 | 13 13 | 13 19 | my ($b1, $b2) = @{ $rule_b->{prt}->{range} }; | ||||
| 17039 | 13 | 23 | if ($a2 + 1 == $b1) { | ||||
| 17040 | |||||||
| 17041 | # Found adjacent port ranges. | ||||||
| 17042 | 8 | 24 | if (my $range = delete $rule_a->{range}) { | ||||
| 17043 | |||||||
| 17044 | # Extend range of previous two or | ||||||
| 17045 | # more elements. | ||||||
| 17046 | 2 | 1 | $range->[1] = $b2; | ||||
| 17047 | 2 | 2 | $rule_b->{range} = $range; | ||||
| 17048 | } | ||||||
| 17049 | else { | ||||||
| 17050 | |||||||
| 17051 | # Combine ranges of $rule_a and $rule_b. | ||||||
| 17052 | 6 | 13 | $rule_b->{range} = [ $a1, $b2 ]; | ||||
| 17053 | } | ||||||
| 17054 | |||||||
| 17055 | # Mark previous rule as deleted. | ||||||
| 17056 | # Don't use attribute 'deleted', this | ||||||
| 17057 | # may still be set by global | ||||||
| 17058 | # optimization pass. | ||||||
| 17059 | 8 | 14 | $rule_a->{local_del} = 1; | ||||
| 17060 | 8 | 8 | $changed = 1; | ||||
| 17061 | } | ||||||
| 17062 | 13 | 10 | $rule_a = $rule_b; | ||||
| 17063 | 13 | 55 | ($a1, $a2) = ($b1, $b2); | ||||
| 17064 | } | ||||||
| 17065 | } | ||||||
| 17066 | } | ||||||
| 17067 | } | ||||||
| 17068 | } | ||||||
| 17069 | } | ||||||
| 17070 | 1542 | 2793 | if ($changed) { | ||||
| 17071 | 12 | 13 | my @rules; | ||||
| 17072 | 12 12 | 9 24 | for my $rule (@{ $hardware->{$rules} }) { | ||||
| 17073 | |||||||
| 17074 | # Check and remove attribute 'local_del'. | ||||||
| 17075 | 26 | 41 | next if delete $rule->{local_del}; | ||||
| 17076 | |||||||
| 17077 | # Process rules with joined port ranges. | ||||||
| 17078 | # Remove auxiliary attribute {range} from rules. | ||||||
| 17079 | 18 | 30 | if (my $range = delete $rule->{range}) { | ||||
| 17080 | 6 | 7 | my $prt = $rule->{prt}; | ||||
| 17081 | 6 | 8 | my $proto = $prt->{proto}; | ||||
| 17082 | 6 | 13 | my $key = join(':', @$range); | ||||
| 17083 | |||||||
| 17084 | # Try to find existing prt with matching range. | ||||||
| 17085 | # This is needed for find_object_groups to work. | ||||||
| 17086 | 6 | 11 | my $new_prt = $prt_hash{$proto}->{$key}; | ||||
| 17087 | 6 | 10 | unless ($new_prt) { | ||||
| 17088 | 5 | 18 | $new_prt = { | ||||
| 17089 | name => "joined:$prt->{name}", | ||||||
| 17090 | proto => $proto, | ||||||
| 17091 | range => $range | ||||||
| 17092 | }; | ||||||
| 17093 | 5 | 9 | $prt_hash{$proto}->{$key} = $new_prt; | ||||
| 17094 | } | ||||||
| 17095 | 6 | 22 | my $new_rule = { %$rule, prt => $new_prt }; | ||||
| 17096 | 6 | 14 | push @rules, $new_rule; | ||||
| 17097 | } | ||||||
| 17098 | else { | ||||||
| 17099 | 12 | 17 | push @rules, $rule; | ||||
| 17100 | } | ||||||
| 17101 | } | ||||||
| 17102 | 12 | 39 | $hardware->{$rules} = \@rules; | ||||
| 17103 | } | ||||||
| 17104 | } | ||||||
| 17105 | 514 | 1155 | return; | ||||
| 17106 | } | ||||||
| 17107 | |||||||
| 17108 | # Reuse network objects at different interfaces, | ||||||
| 17109 | # so we get reused object-groups. | ||||||
| 17110 | my %filter_networks; | ||||||
| 17111 | |||||||
| 17112 | sub get_filter_network { | ||||||
| 17113 | 38 | 0 | 38 | my ($ip, $mask) = @_; | |||
| 17114 | 38 | 57 | my $key = "$ip/$mask"; | ||||
| 17115 | 38 | 39 | my $net = $filter_networks{$key}; | ||||
| 17116 | 38 | 54 | if (!$net) { | ||||
| 17117 | 14 | 20 | $net = new('Network', ip => $ip, mask => $mask); | ||||
| 17118 | 14 | 16 | $filter_networks{$key} = $net; | ||||
| 17119 | 14 | 24 | $ref2obj{$net} = $net; | ||||
| 17120 | } | ||||||
| 17121 | 38 | 76 | return $net; | ||||
| 17122 | } | ||||||
| 17123 | |||||||
| 17124 | # Remove rules on device which filters only locally. | ||||||
| 17125 | sub remove_non_local_rules { | ||||||
| 17126 | 514 | 0 | 466 | my ($router, $hardware) = @_; | |||
| 17127 | 514 | 1046 | $router->{managed} =~ /^local/ or return; | ||||
| 17128 | |||||||
| 17129 | 35 | 37 | my $no_nat_set = $hardware->{no_nat_set}; | ||||
| 17130 | 35 | 29 | my $filter_only = $router->{filter_only}; | ||||
| 17131 | 35 | 36 | for my $rules ('rules', 'out_rules') { | ||||
| 17132 | 70 | 48 | my $changed; | ||||
| 17133 | 70 70 | 52 105 | for my $rule (@{ $hardware->{$rules} }) { | ||||
| 17134 | |||||||
| 17135 | # Don't remove deny rule | ||||||
| 17136 | 27 | 41 | next if $rule->{deny}; | ||||
| 17137 | 27 | 25 | my $both_match = 0; | ||||
| 17138 | 27 | 22 | for my $what (qw(src dst)) { | ||||
| 17139 | 54 | 56 | my $obj = $rule->{$what}; | ||||
| 17140 | 54 54 | 39 64 | my ($ip, $mask) = @{ address($obj, $no_nat_set) }; | ||||
| 17141 | 54 | 71 | for my $pair (@$filter_only) { | ||||
| 17142 | 56 | 55 | my ($i, $m) = @$pair; | ||||
| 17143 | |||||||
| 17144 | # src/dst matches filter_only or | ||||||
| 17145 | # filter_only matches src/dst. | ||||||
| 17146 | 56 | 119 | if ($mask > $m && match_ip($ip, $i, $m) || | ||||
| 17147 | match_ip($i, $ip, $mask)) | ||||||
| 17148 | { | ||||||
| 17149 | 50 | 38 | $both_match++; | ||||
| 17150 | 50 | 79 | last; | ||||
| 17151 | } | ||||||
| 17152 | } | ||||||
| 17153 | } | ||||||
| 17154 | |||||||
| 17155 | # Either src or dst or both are extern. | ||||||
| 17156 | # The rule will not be filtered at this device. | ||||||
| 17157 | 27 | 53 | if ($both_match < 2) { | ||||
| 17158 | 4 | 3 | $rule = undef; | ||||
| 17159 | 4 | 6 | $changed = 1; | ||||
| 17160 | } | ||||||
| 17161 | } | ||||||
| 17162 | $changed and | ||||||
| 17163 | 70 6 4 | 125 10 6 | $hardware->{$rules} = [ grep { $_ } @{ $hardware->{$rules} } ]; | ||||
| 17164 | } | ||||||
| 17165 | 35 | 44 | return; | ||||
| 17166 | } | ||||||
| 17167 | |||||||
| 17168 | # Add deny and permit rules at device which filters only locally. | ||||||
| 17169 | sub add_local_deny_rules { | ||||||
| 17170 | 514 | 0 | 491 | my ($router, $hardware) = @_; | |||
| 17171 | 514 | 1102 | $router->{managed} =~ /^local/ or return; | ||||
| 17172 | 35 | 57 | $hardware->{crosslink} and return; | ||||
| 17173 | |||||||
| 17174 | 32 | 28 | my $filter_only = $router->{filter_only}; | ||||
| 17175 | 32 38 | 34 53 | my @dst_networks = map { get_filter_network(@$_) } @$filter_only; | ||||
| 17176 | |||||||
| 17177 | 32 | 38 | for my $attr (qw(rules out_rules)) { | ||||
| 17178 | |||||||
| 17179 | 64 | 167 | next if $attr eq 'rules' && $hardware->{no_in_acl}; | ||||
| 17180 | 63 | 163 | next if $attr eq 'out_rules' && ! $hardware->{need_out_acl}; | ||||
| 17181 | |||||||
| 17182 | # If attached zone has only one connection to this firewall | ||||||
| 17183 | # than we don't need to check the source address. It has | ||||||
| 17184 | # already been checked, that all networks of this zone match | ||||||
| 17185 | # {filter_only}. | ||||||
| 17186 | my $check = sub { | ||||||
| 17187 | 32 | 53 | $attr eq 'out_rules' and return; | ||||
| 17188 | 31 31 | 20 44 | for my $interface (@{ $hardware->{interfaces} }) { | ||||
| 17189 | 33 | 32 | my $zone = $interface->{zone}; | ||||
| 17190 | 33 | 47 | $zone->{zone_cluster} and return; | ||||
| 17191 | |||||||
| 17192 | # Ignore real interface of virtual interface. | ||||||
| 17193 | 69 33 | 118 37 | my @interfaces = grep({ ! $_->{main_interface} } | ||||
| 17194 | 33 | 27 | @{ $zone->{interfaces} }); | ||||
| 17195 | |||||||
| 17196 | 33 | 66 | if (@interfaces > 1) { | ||||
| 17197 | |||||||
| 17198 | |||||||
| 17199 | # Multilpe interfaces belonging to one redundancy | ||||||
| 17200 | # group can't be used to cross the zone. | ||||||
| 17201 | 47 | 40 | my @redundant = | ||||
| 17202 | 47 | 56 | grep { $_ } | ||||
| 17203 | 19 | 19 | map { $_->{redundancy_interfaces} } @interfaces; | ||||
| 17204 | 19 | 64 | @redundant == @interfaces and equal(@redundant) | ||||
| 17205 | or return; | ||||||
| 17206 | } | ||||||
| 17207 | } | ||||||
| 17208 | 16 | 34 | return 1; | ||||
| 17209 | 32 | 95 | }; | ||||
| 17210 | 32 | 45 | my @src_networks = $check->() ? ($network_00) : @dst_networks; | ||||
| 17211 | |||||||
| 17212 | 32 | 25 | my @filter_rules; | ||||
| 17213 | 32 | 32 | for my $src (@src_networks) { | ||||
| 17214 | 35 | 30 | for my $dst (@dst_networks) { | ||||
| 17215 | 44 | 142 | push(@filter_rules, | ||||
| 17216 | { | ||||||
| 17217 | deny => 1, | ||||||
| 17218 | src => $src, | ||||||
| 17219 | dst => $dst, | ||||||
| 17220 | prt => $prt_ip | ||||||
| 17221 | }); | ||||||
| 17222 | } | ||||||
| 17223 | } | ||||||
| 17224 | 32 | 37 | my $rules = $hardware->{$attr}; | ||||
| 17225 | 32 | 156 | push @$rules, @filter_rules, $permit_any_rule; | ||||
| 17226 | } | ||||||
| 17227 | 32 | 41 | return; | ||||
| 17228 | } | ||||||
| 17229 | |||||||
| 17230 | sub prepare_local_optimization { | ||||||
| 17231 | |||||||
| 17232 | # Prepare rules for local_optimization. | ||||||
| 17233 | # Aggregates with mask 0 are converted to network_00, to be able | ||||||
| 17234 | # to compare with internally generated rules which use network_00. | ||||||
| 17235 | 155 155 | 0 | 150 240 | for my $rule (@{ $expanded_rules{supernet} }) { | |||
| 17236 | 105 | 214 | next if $rule->{deleted} and not $rule->{managed_intf}; | ||||
| 17237 | 104 104 | 89 150 | my ($src, $dst) = @{$rule}{qw(src dst)}; | ||||
| 17238 | 104 | 133 | $rule->{src} = $network_00 if is_network($src) && $src->{mask} == 0; | ||||
| 17239 | 104 | 136 | $rule->{dst} = $network_00 if is_network($dst) && $dst->{mask} == 0; | ||||
| 17240 | } | ||||||
| 17241 | 155 | 145 | return; | ||||
| 17242 | } | ||||||
| 17243 | |||||||
| 17244 | #use Time::HiRes qw ( time ); | ||||||
| 17245 | sub local_optimization { | ||||||
| 17246 | 208 | 0 | 260 | return if fast_mode(); | |||
| 17247 | 155 | 233 | progress('Optimizing locally'); | ||||
| 17248 | |||||||
| 17249 | # Needed in find_chains. | ||||||
| 17250 | 155 | 286 | $ref2obj{$network_00} = $network_00; | ||||
| 17251 | |||||||
| 17252 | 155 | 127 | my %seen; | ||||
| 17253 | |||||||
| 17254 | # For debugging only | ||||||
| 17255 | # my %time; | ||||||
| 17256 | # my %r2rules; | ||||||
| 17257 | # my %r2id; | ||||||
| 17258 | # my %r2del; | ||||||
| 17259 | # my %r2sec; | ||||||
| 17260 | 155 | 195 | for my $domain (@natdomains) { | ||||
| 17261 | 189 | 201 | my $no_nat_set = $domain->{no_nat_set}; | ||||
| 17262 | |||||||
| 17263 | # Subnet relation may be different for each NAT domain, | ||||||
| 17264 | # therefore it is set up again for each NAT domain. | ||||||
| 17265 | 189 | 195 | for my $network (@networks) { | ||||
| 17266 | 841 | 2434 | next if !$network->{mask} || $network->{mask} == 0; | ||||
| 17267 | 739 | 932 | my $up = $network->{is_in}->{$no_nat_set}; | ||||
| 17268 | 739 | 1588 | if (!$up || $up->{mask} == 0) { | ||||
| 17269 | 629 | 499 | $up = $network_00; | ||||
| 17270 | } | ||||||
| 17271 | 739 | 938 | $network->{up} = $up; | ||||
| 17272 | } | ||||||
| 17273 | |||||||
| 17274 | 189 189 | 190 242 | for my $network (@{ $domain->{networks} }) { | ||||
| 17275 | |||||||
| 17276 | # Iterate over all interfaces attached to current network. | ||||||
| 17277 | # If interface is virtual tunnel for multiple software clients, | ||||||
| 17278 | # take separate rules for each software client. | ||||||
| 17279 | 587 2 | 450 5 | for my $interface ( | ||||
| 17280 | 870 587 | 1618 753 | map { $_->{id_rules} ? values %{ $_->{id_rules} } : $_ } | ||||
| 17281 | @{ $network->{interfaces} }) | ||||||
| 17282 | { | ||||||
| 17283 | 873 | 789 | my $router = $interface->{router}; | ||||
| 17284 | 873 | 1567 | my $managed = $router->{managed} or next; | ||||
| 17285 | 615 | 705 | my $secondary_filter = $managed =~ /secondary$/; | ||||
| 17286 | 615 | 605 | my $standard_filter = $managed eq 'standard'; | ||||
| 17287 | 615 | 628 | my $do_auth = $router->{model}->{do_auth}; | ||||
| 17288 | 615 | 917 | my $hardware = | ||||
| 17289 | $interface->{ip} eq 'tunnel' | ||||||
| 17290 | ? $interface | ||||||
| 17291 | : $interface->{hardware}; | ||||||
| 17292 | |||||||
| 17293 | # Do local optimization only once for each hardware interface. | ||||||
| 17294 | 615 | 1135 | next if $seen{$hardware}; | ||||
| 17295 | 574 | 828 | $seen{$hardware} = 1; | ||||
| 17296 | |||||||
| 17297 | 574 | 969 | if ($router->{model}->{filter} eq 'iptables') { | ||||
| 17298 | 60 | 94 | find_chains $router, $hardware; | ||||
| 17299 | 60 | 130 | next; | ||||
| 17300 | } | ||||||
| 17301 | |||||||
| 17302 | 514 | 678 | remove_non_local_rules($router, $hardware); | ||||
| 17303 | |||||||
| 17304 | # my $rname = $router->{name}; | ||||||
| 17305 | # debug("$router->{name}"); | ||||||
| 17306 | 514 | 514 | for my $rules ('intf_rules', 'rules', 'out_rules') { | ||||
| 17307 | |||||||
| 17308 | # my $t1 = time(); | ||||||
| 17309 | |||||||
| 17310 | # For supernet / aggregate rules used in optimization. | ||||||
| 17311 | 1542 | 1112 | my %hash; | ||||
| 17312 | |||||||
| 17313 | # For finding duplicate rules having src or dst | ||||||
| 17314 | # which exist as different objects with identical | ||||||
| 17315 | # ip address. | ||||||
| 17316 | my %id_hash; | ||||||
| 17317 | |||||||
| 17318 | # For finding duplicate secondary rules. | ||||||
| 17319 | 0 | 0 | my %id_hash2; | ||||
| 17320 | |||||||
| 17321 | 1542 | 1138 | my $changed = 0; | ||||
| 17322 | 1542 1542 | 1108 2351 | for my $rule (@{ $hardware->{$rules} }) { | ||||
| 17323 | |||||||
| 17324 | # Change rule to allow optimization of objects | ||||||
| 17325 | # having identical IP address. | ||||||
| 17326 | 571 | 540 | for my $what (qw(src dst)) { | ||||
| 17327 | 1142 | 1048 | my $obj = $rule->{$what}; | ||||
| 17328 | 1142 | 806 | my $obj_changed; | ||||
| 17329 | |||||||
| 17330 | # Change loopback interface to loopback network. | ||||||
| 17331 | # The loopback network is additionally checked | ||||||
| 17332 | # below. | ||||||
| 17333 | 1142 | 1860 | if ($obj->{loopback} && | ||||
| 17334 | (my $network = $obj->{network})) | ||||||
| 17335 | { | ||||||
| 17336 | 14 | 45 | if (!($rules eq 'intf_rules' && $what eq 'dst')) | ||||
| 17337 | { | ||||||
| 17338 | 8 | 5 | $obj = $network; | ||||
| 17339 | 8 | 9 | $obj_changed = 1; | ||||
| 17340 | } | ||||||
| 17341 | } | ||||||
| 17342 | |||||||
| 17343 | # Identical networks from dynamic NAT and | ||||||
| 17344 | # from identical aggregates. | ||||||
| 17345 | 1142 | 2162 | if (my $identical = $obj->{is_identical}) { | ||||
| 17346 | 22 | 47 | if (my $other = $identical->{$no_nat_set}) { | ||||
| 17347 | 19 | 20 | $obj = $other; | ||||
| 17348 | 19 | 24 | $obj_changed = 1; | ||||
| 17349 | } | ||||||
| 17350 | } | ||||||
| 17351 | |||||||
| 17352 | # Identical redundancy interfaces. | ||||||
| 17353 | elsif (my $aref = $obj->{redundancy_interfaces}) { | ||||||
| 17354 | 13 | 40 | if ( | ||||
| 17355 | !($rules eq 'intf_rules' && $what eq 'dst') | ||||||
| 17356 | || ( $router->{crosslink_intf_hash} | ||||||
| 17357 | && $router->{crosslink_intf_hash} | ||||||
| 17358 | ->{ $aref->[0] }) | ||||||
| 17359 | ) | ||||||
| 17360 | { | ||||||
| 17361 | 11 | 11 | $obj = $aref->[0]; | ||||
| 17362 | 11 | 9 | $obj_changed = 1; | ||||
| 17363 | } | ||||||
| 17364 | } | ||||||
| 17365 | |||||||
| 17366 | 1142 | 1978 | $obj_changed or next; | ||||
| 17367 | |||||||
| 17368 | # Don't change rules of devices in other | ||||||
| 17369 | # NAT domain where we may have other | ||||||
| 17370 | # relation. | ||||||
| 17371 | 38 | 190 | $rule = { %$rule, $what => $obj }; | ||||
| 17372 | } | ||||||
| 17373 | 571 | 835 | my ($src, $dst, $deny, $src_range, $prt) = | ||||
| 17374 | 571 | 555 | @{$rule}{qw(src dst deny src_range prt)}; | ||||
| 17375 | 571 | 1373 | $deny ||= ''; | ||||
| 17376 | 571 | 1199 | $src_range ||= $prt_ip; | ||||
| 17377 | |||||||
| 17378 | # Remove duplicate rules. | ||||||
| 17379 | 571 | 2084 | if ($id_hash{$deny}->{$src_range}->{$src}->{$dst} | ||||
| 17380 | ->{$prt}) | ||||||
| 17381 | { | ||||||
| 17382 | 43 | 40 | $rule = undef; | ||||
| 17383 | 43 | 57 | $changed = 1; | ||||
| 17384 | |||||||
| 17385 | # $r2id{$rname}++; | ||||||
| 17386 | 43 | 74 | next; | ||||
| 17387 | } | ||||||
| 17388 | 528 | 1630 | $id_hash{$deny}->{$src_range}->{$src}->{$dst} | ||||
| 17389 | ->{$prt} = $rule; | ||||||
| 17390 | |||||||
| 17391 | 528 | 2438 | if ( $src->{is_supernet} | ||||
| 17392 | || $dst->{is_supernet} | ||||||
| 17393 | || $rule->{stateless}) | ||||||
| 17394 | { | ||||||
| 17395 | 188 | 805 | $hash{$deny}->{$src_range}->{$src}->{$dst} | ||||
| 17396 | ->{$prt} = $rule; | ||||||
| 17397 | } | ||||||
| 17398 | } | ||||||
| 17399 | |||||||
| 17400 | # my $t2 = time(); | ||||||
| 17401 | # $time{$rname}[0] += $t2-$t1; | ||||||
| 17402 | RULE: | ||||||
| 17403 | 1542 1542 | 1237 1863 | for my $rule (@{ $hardware->{$rules} }) { | ||||
| 17404 | 571 | 843 | next if not $rule; | ||||
| 17405 | |||||||
| 17406 | # my $t3 = time(); | ||||||
| 17407 | # $r2rules{$rname}++; | ||||||
| 17408 | |||||||
| 17409 | # debug(print_rule $rule); | ||||||
| 17410 | # debug "is_supernet" if $rule->{dst}->{is_supernet}; | ||||||
| 17411 | 528 | 827 | my ($deny, $src, $dst, $src_range, $prt, $log) = | ||||
| 17412 | 528 | 428 | @{$rule}{qw(deny src dst src_range prt log)}; | ||||
| 17413 | 528 | 1271 | $deny ||= ''; | ||||
| 17414 | 528 | 1105 | $src_range ||= $prt_ip; | ||||
| 17415 | 528 | 1124 | $log ||= ''; | ||||
| 17416 | |||||||
| 17417 | 528 | 375 | while (1) { | ||||
| 17418 | 1044 | 800 | my $src_range = $src_range; | ||||
| 17419 | 1044 | 1549 | if (my $hash = $hash{$deny}) { | ||||
| 17420 | 253 | 179 | while (1) { | ||||
| 17421 | 267 | 211 | my $src = $src; | ||||
| 17422 | 267 | 515 | if (my $hash = $hash->{$src_range}) { | ||||
| 17423 | 253 | 190 | while (1) { | ||||
| 17424 | 507 | 364 | my $dst = $dst; | ||||
| 17425 | 507 | 874 | if (my $hash = $hash->{$src}) { | ||||
| 17426 | 258 | 206 | while (1) { | ||||
| 17427 | 524 | 382 | my $prt = $prt; | ||||
| 17428 | 524 | 895 | if (my $hash = $hash->{$dst}) { | ||||
| 17429 | 260 | 211 | while (1) { | ||||
| 17430 | 676 | 1073 | if (my $other_rule = $hash->{$prt}) { | ||||
| 17431 | 203 | 530 | my $o_log = $other_rule->{log} || ''; | ||||
| 17432 | 203 | 530 | if ($rule ne $other_rule && $log eq $o_log) { | ||||
| 17433 | |||||||
| 17434 | # debug("del:", print_rule $rule); | ||||||
| 17435 | # debug("oth:", print_rule $other_rule); | ||||||
| 17436 | 12 | 10 | $rule = undef; | ||||
| 17437 | |||||||
| 17438 | # $r2del{$rname}++; | ||||||
| 17439 | 12 | 11 | $changed = 1; | ||||
| 17440 | |||||||
| 17441 | # $time{$rname}[1] += time()-$t3; | ||||||
| 17442 | 12 | 44 | next RULE; | ||||
| 17443 | } | ||||||
| 17444 | } | ||||||
| 17445 | 664 | 1042 | $prt = $prt->{up} or last; | ||||
| 17446 | } | ||||||
| 17447 | } | ||||||
| 17448 | 512 | 825 | $dst = $dst->{up} or last; | ||||
| 17449 | } | ||||||
| 17450 | } | ||||||
| 17451 | 495 | 791 | $src = $src->{up} or last; | ||||
| 17452 | } | ||||||
| 17453 | } | ||||||
| 17454 | 255 | 456 | $src_range = $src_range->{up} or last; | ||||
| 17455 | } | ||||||
| 17456 | } | ||||||
| 17457 | 1032 | 1385 | last if $deny; | ||||
| 17458 | 516 | 441 | $deny = 1; | ||||
| 17459 | } | ||||||
| 17460 | |||||||
| 17461 | # my $t4 = time(); | ||||||
| 17462 | # $time{$rname}[1] += $t4-$t3; | ||||||
| 17463 | |||||||
| 17464 | # Implement remaining rules as secondary rule, | ||||||
| 17465 | # if possible. | ||||||
| 17466 | 516 | 2544 | if ( $secondary_filter && $rule->{some_non_secondary} | ||||
| 17467 | || $standard_filter && $rule->{some_primary}) | ||||||
| 17468 | { | ||||||
| 17469 | 15 | 28 | $rule->{deny} and internal_err(); | ||||
| 17470 | 15 15 | 17 21 | my ($src, $dst) = @{$rule}{qw(src dst)}; | ||||
| 17471 | |||||||
| 17472 | # Replace obj by largest supernet in zone, | ||||||
| 17473 | # which has no subnet in other zone. | ||||||
| 17474 | # We must not change to network having subnet in | ||||||
| 17475 | # other zone, because then we had to do | ||||||
| 17476 | # check_supernet_rules for newly created | ||||||
| 17477 | # secondary rules. | ||||||
| 17478 | 15 | 26 | for my $ref (\$src, \$dst) { | ||||
| 17479 | |||||||
| 17480 | # Restrict secondary optimization at | ||||||
| 17481 | # authenticating router to prevent | ||||||
| 17482 | # unauthorized access with spoofed IP | ||||||
| 17483 | # address. | ||||||
| 17484 | 30 | 51 | if ($do_auth) { | ||||
| 17485 | 0 | 0 | my $type = ref($$ref); | ||||
| 17486 | |||||||
| 17487 | # Single ID-hosts must not be | ||||||
| 17488 | # converted to network. | ||||||
| 17489 | 0 | 0 | if ($type eq 'Subnet') { | ||||
| 17490 | 0 | 0 | next if $$ref->{id}; | ||||
| 17491 | } | ||||||
| 17492 | |||||||
| 17493 | # Network with ID-hosts must not | ||||||
| 17494 | # be optimized at all. | ||||||
| 17495 | elsif ($type eq 'Network') { | ||||||
| 17496 | 0 | 0 | next RULE if $$ref->{has_id_hosts}; | ||||
| 17497 | } | ||||||
| 17498 | } | ||||||
| 17499 | 30 | 86 | if ( | ||||
| 17500 | $$ref eq $dst | ||||||
| 17501 | && is_interface($dst) | ||||||
| 17502 | && ( | ||||||
| 17503 | $dst->{router} eq $router | ||||||
| 17504 | || ( $router->{crosslink_intf_hash} | ||||||
| 17505 | and $router->{crosslink_intf_hash} | ||||||
| 17506 | ->{$dst}) | ||||||
| 17507 | ) | ||||||
| 17508 | ) | ||||||
| 17509 | { | ||||||
| 17510 | 1 | 2 | next; | ||||
| 17511 | } | ||||||
| 17512 | 29 | 45 | if (is_subnet($$ref) || is_interface($$ref)) { | ||||
| 17513 | 7 | 9 | my $net = $$ref->{network}; | ||||
| 17514 | 7 | 17 | next if $net->{has_other_subnet}; | ||||
| 17515 | 4 | 5 | $$ref = $net; | ||||
| 17516 | } | ||||||
| 17517 | 26 | 50 | if (my $max = $$ref->{max_secondary_net}) { | ||||
| 17518 | 3 | 5 | $$ref = $max; | ||||
| 17519 | } | ||||||
| 17520 | |||||||
| 17521 | # Prevent duplicate ACLs for networks which | ||||||
| 17522 | # are translated to the same ip address. | ||||||
| 17523 | 26 | 56 | if (my $identical = $$ref->{is_identical}) { | ||||
| 17524 | 0 | 0 | if (my $one_net = $identical->{$no_nat_set}) | ||||
| 17525 | { | ||||||
| 17526 | 0 | 0 | $$ref = $one_net; | ||||
| 17527 | } | ||||||
| 17528 | } | ||||||
| 17529 | } | ||||||
| 17530 | |||||||
| 17531 | # Add new rule to hash. If there are multiple | ||||||
| 17532 | # rules which could be converted to the same | ||||||
| 17533 | # secondary rule, only the first one will be | ||||||
| 17534 | # generated. | ||||||
| 17535 | 15 | 46 | if (my $old = $id_hash2{$src}->{$dst}) { | ||||
| 17536 | |||||||
| 17537 | 0 | 0 | if ($old ne $rule) { | ||||
| 17538 | |||||||
| 17539 | # debug("sec delete: ", print_rule $rule); | ||||||
| 17540 | |||||||
| 17541 | 0 | 0 | $rule = undef; | ||||
| 17542 | 0 | 0 | $changed = 1; | ||||
| 17543 | |||||||
| 17544 | # $r2sec{$rname}++; | ||||||
| 17545 | } | ||||||
| 17546 | } | ||||||
| 17547 | else { | ||||||
| 17548 | |||||||
| 17549 | # Don't modify original rule, because the | ||||||
| 17550 | # identical rule is referenced at different | ||||||
| 17551 | # routers. | ||||||
| 17552 | 15 | 32 | my $new_rule = { | ||||
| 17553 | src => $src, | ||||||
| 17554 | dst => $dst, | ||||||
| 17555 | prt => $prt_ip, | ||||||
| 17556 | }; | ||||||
| 17557 | 15 | 30 | $new_rule->{log} = $rule->{log} if $rule->{log}; | ||||
| 17558 | |||||||
| 17559 | # debug("sec: ", print_rule $new_rule); | ||||||
| 17560 | 15 | 28 | $id_hash2{$src}->{$dst} = $new_rule; | ||||
| 17561 | |||||||
| 17562 | # This only works if smaller rule isn't | ||||||
| 17563 | # already processed. | ||||||
| 17564 | 15 | 47 | if ($src->{is_supernet} || $dst->{is_supernet}) | ||||
| 17565 | { | ||||||
| 17566 | 8 | 29 | $hash{''}->{$prt_ip}->{$src}->{$dst} | ||||
| 17567 | ->{$prt_ip} = $new_rule; | ||||||
| 17568 | } | ||||||
| 17569 | |||||||
| 17570 | # This changes @{$hardware->{$rules}} ! | ||||||
| 17571 | 15 | 33 | $rule = $new_rule; | ||||
| 17572 | } | ||||||
| 17573 | } | ||||||
| 17574 | |||||||
| 17575 | # my $t5 = time(); | ||||||
| 17576 | # $time{$rname}[2] += $t5-$t4; | ||||||
| 17577 | } | ||||||
| 17578 | 1542 | 3426 | if ($changed) { | ||||
| 17579 | 113 | 288 | $hardware->{$rules} = | ||||
| 17580 | 38 38 | 43 59 | [ grep { defined $_ } @{ $hardware->{$rules} } ]; | ||||
| 17581 | } | ||||||
| 17582 | } | ||||||
| 17583 | |||||||
| 17584 | 514 | 761 | add_local_deny_rules($router, $hardware); | ||||
| 17585 | |||||||
| 17586 | # Join adjacent port ranges. This must be called after local | ||||||
| 17587 | # optimization has been finished, because protocols will be | ||||||
| 17588 | # overlapping again after joining. | ||||||
| 17589 | # my $t6 = time(); | ||||||
| 17590 | 514 | 631 | join_ranges($router, $hardware); | ||||
| 17591 | |||||||
| 17592 | # $time{$rname}[3] += time() - $t6; | ||||||
| 17593 | } | ||||||
| 17594 | } | ||||||
| 17595 | } | ||||||
| 17596 | |||||||
| 17597 | # my ($orules, $oid, $odel, $osec, $arules, $aid, $adel, $asec, | ||||||
| 17598 | # @otime, @atime); | ||||||
| 17599 | # my $f = '%-12s %7i %7i %7i %7i %.3f %.3f %.3f %.3f %.3f'; | ||||||
| 17600 | # for my $aref (values %time) { | ||||||
| 17601 | # $aref->[4] = $aref->[0] + $aref->[1] + $aref->[2] + $aref->[3]; | ||||||
| 17602 | # $atime[0] += $aref->[0]; | ||||||
| 17603 | # $atime[1] += $aref->[1]; | ||||||
| 17604 | # $atime[2] += $aref->[2]; | ||||||
| 17605 | # $atime[3] += $aref->[3]; | ||||||
| 17606 | # $atime[4] += $aref->[4]; | ||||||
| 17607 | # } | ||||||
| 17608 | # for my $name (sort { $time{$a}[4] <=> $time{$b}[4] } keys %time) { | ||||||
| 17609 | # my $pre = $time{$name}[0]; | ||||||
| 17610 | # my $while = $time{$name}[1]; | ||||||
| 17611 | # my $secon = $time{$name}[2]; | ||||||
| 17612 | # my $join = $time{$name}[3]; | ||||||
| 17613 | # my $sum = $time{$name}[4]; | ||||||
| 17614 | # my $rules = $r2rules{$name}; | ||||||
| 17615 | # my $id = $r2id{$name} || 0; | ||||||
| 17616 | # my $del = $r2del{$name} || 0; | ||||||
| 17617 | # my $sec = $r2sec{$name} || 0; | ||||||
| 17618 | # $arules += $rules; | ||||||
| 17619 | # $aid += $id; | ||||||
| 17620 | # $adel += $del; | ||||||
| 17621 | # $asec += $sec; | ||||||
| 17622 | # if ($sum < 0.5) { | ||||||
| 17623 | # $otime[0] += $pre; | ||||||
| 17624 | # $otime[1] += $while; | ||||||
| 17625 | # $otime[2] += $secon; | ||||||
| 17626 | # $otime[3] += $join; | ||||||
| 17627 | # $otime[4] += $sum; | ||||||
| 17628 | # $orules += $rules; | ||||||
| 17629 | # $odel += $del; | ||||||
| 17630 | # $oid += $id; | ||||||
| 17631 | # $osec += $sec; | ||||||
| 17632 | # } | ||||||
| 17633 | # else { | ||||||
| 17634 | # $name =~ s/^router://; | ||||||
| 17635 | # debug(sprintf( $f, $name, $rules, $id, $del, $sec, | ||||||
| 17636 | # $pre, $while, $secon, $join, $sum)); | ||||||
| 17637 | # } | ||||||
| 17638 | # } | ||||||
| 17639 | # debug(sprintf( $f, 'other', $orules, $oid, $odel, $osec, | ||||||
| 17640 | # $otime[0], $otime[1], $otime[2], $otime[3], $otime[4])); | ||||||
| 17641 | # debug(sprintf( $f, 'all', $arules, $aid, $adel, $asec, | ||||||
| 17642 | # $atime[0], $atime[1], $atime[2], $atime[3], $atime[4])); | ||||||
| 17643 | |||||||
| 17644 | 155 | 268 | return; | ||||
| 17645 | } | ||||||
| 17646 | |||||||
| 17647 | my $deny_any_rule; | ||||||
| 17648 | |||||||
| 17649 | sub print_cisco_acl_add_deny { | ||||||
| 17650 | 481 | 0 | 582 | my ($router, $hardware, $no_nat_set, $model, $prefix) = @_; | |||
| 17651 | 481 | 357 | my $permit_any; | ||||
| 17652 | |||||||
| 17653 | 481 | 785 | my $rules = $hardware->{rules} ||= []; | ||||
| 17654 | 481 | 705 | if (@$rules) { | ||||
| 17655 | 235 | 402 | my ($deny, $src, $dst, $prt) = | ||||
| 17656 | 235 | 210 | @{ $rules->[-1] }{ 'deny', 'src', 'dst', 'prt' }; | ||||
| 17657 | 235 | 548 | $permit_any = | ||||
| 17658 | !$deny | ||||||
| 17659 | && is_network($src) | ||||||
| 17660 | && $src->{mask} == 0 | ||||||
| 17661 | && is_network($dst) | ||||||
| 17662 | && $dst->{mask} == 0 | ||||||
| 17663 | && $prt eq $prt_ip; | ||||||
| 17664 | } | ||||||
| 17665 | |||||||
| 17666 | # Add permit or deny rule at end of ACL | ||||||
| 17667 | # unless the previous rule is 'permit ip any any'. | ||||||
| 17668 | 481 | 703 | if (!$permit_any) { | ||||
| 17669 | 447 | 852 | push( | ||||
| 17670 | 447 | 343 | @{ $hardware->{rules} }, | ||||
| 17671 | $hardware->{no_in_acl} ? $permit_any_rule : $deny_any_rule | ||||||
| 17672 | ); | ||||||
| 17673 | 447 | 459 | $permit_any = $hardware->{no_in_acl}; | ||||
| 17674 | } | ||||||
| 17675 | |||||||
| 17676 | 481 | 1161 | if ($router->{need_protect} || | ||||
| 17677 | |||||||
| 17678 | # ASA protects IOS router behind crosslink interface. | ||||||
| 17679 | $router->{crosslink_intf_hash}) | ||||||
| 17680 | { | ||||||
| 17681 | |||||||
| 17682 | # Routers connected by crosslink networks are handled like one | ||||||
| 17683 | # large router. Protect the collected interfaces of the whole | ||||||
| 17684 | # cluster at each entry. | ||||||
| 17685 | 280 | 251 | my $interfaces = $router->{crosslink_interfaces}; | ||||
| 17686 | 280 | 405 | if (!$interfaces) { | ||||
| 17687 | 262 | 239 | $interfaces = $router->{interfaces}; | ||||
| 17688 | 262 | 403 | if ($model->{has_vip}) { | ||||
| 17689 | 7 15 | 10 28 | $interfaces = [ grep { !$_->{vip} } @$interfaces ]; | ||||
| 17690 | } | ||||||
| 17691 | } | ||||||
| 17692 | |||||||
| 17693 | # Set crosslink_intf_hash even for routers not part of a | ||||||
| 17694 | # crosslink cluster. | ||||||
| 17695 | 304 | 693 | $router->{crosslink_intf_hash} ||= | ||||
| 17696 | 280 113 | 502 142 | { map { $_ => $_ } @{ $router->{interfaces} } }; | ||||
| 17697 | 280 | 274 | my $intf_hash = $router->{crosslink_intf_hash}; | ||||
| 17698 | |||||||
| 17699 | # Add deny rules to protect own interfaces. | ||||||
| 17700 | # If a rule permits traffic to a directly connected network | ||||||
| 17701 | # behind the device, this would accidently permit traffic | ||||||
| 17702 | # to an interface of this device as well. | ||||||
| 17703 | |||||||
| 17704 | # Deny rule is needless if there is a rule which permits any | ||||||
| 17705 | # traffic to the interface or | ||||||
| 17706 | # to one interface of a redundancy group. | ||||||
| 17707 | # The permit rule can be deleted if there is a permit any any rule. | ||||||
| 17708 | 280 | 214 | my %no_protect; | ||||
| 17709 | my %seen; | ||||||
| 17710 | 0 | 0 | my $changed; | ||||
| 17711 | 280 280 | 225 404 | for my $rule (@{ $hardware->{intf_rules} }) { | ||||
| 17712 | 62 | 102 | next if $rule->{deny}; | ||||
| 17713 | 62 | 54 | my $src = $rule->{src}; | ||||
| 17714 | 62 | 78 | next if not is_network($src); | ||||
| 17715 | 53 | 125 | next if $src->{mask} != 0; | ||||
| 17716 | 18 | 42 | next if $rule->{prt} ne $prt_ip; | ||||
| 17717 | 9 | 10 | my $dst = $rule->{dst}; | ||||
| 17718 | 9 | 24 | $no_protect{$dst} = 1 if $intf_hash->{$dst}; | ||||
| 17719 | 9 | 14 | $seen{ $dst->{redundancy_interfaces} }++ | ||||
| 17720 | if $dst->{redundancy_interfaces}; | ||||||
| 17721 | |||||||
| 17722 | 9 | 21 | if ($permit_any) { | ||||
| 17723 | 5 | 4 | $rule = undef; | ||||
| 17724 | 5 | 15 | $changed = 1; | ||||
| 17725 | } | ||||||
| 17726 | } | ||||||
| 17727 | 280 | 415 | if ($changed) { | ||||
| 17728 | 5 | 8 | $hardware->{intf_rules} = | ||||
| 17729 | 3 3 | 4 5 | [ grep { defined $_ } @{ $hardware->{intf_rules} } ]; | ||||
| 17730 | } | ||||||
| 17731 | |||||||
| 17732 | # Deny rule is needless if there is no such permit rule. | ||||||
| 17733 | # Try to optimize this case. | ||||||
| 17734 | 280 | 211 | my %need_protect; | ||||
| 17735 | my $protect_all; | ||||||
| 17736 | 280 | 432 | my $local_filter = $router->{managed} =~ /^local/; | ||||
| 17737 | my $check_intf = sub { | ||||||
| 17738 | 97 | 97 | my ($ip, $mask) = @_; | ||||
| 17739 | 97 | 161 | for my $intf (values %$intf_hash) { | ||||
| 17740 | 247 | 573 | next if $intf->{ip} =~ | ||||
| 17741 | /^(unnumbered|negotiated|tunnel|bridged)$/; | ||||||
| 17742 | 239 | 275 | my $i = address($intf, $no_nat_set)->[0]; | ||||
| 17743 | 239 | 338 | if (match_ip($i, $ip, $mask)) { | ||||
| 17744 | 84 | 203 | $need_protect{$intf} = $intf; | ||||
| 17745 | |||||||
| 17746 | # debug("Protect $intf->{name} at $hardware->{name}"); | ||||||
| 17747 | } | ||||||
| 17748 | } | ||||||
| 17749 | 280 | 879 | }; | ||||
| 17750 | 280 | 353 | RULE: | ||||
| 17751 | 280 | 262 | for my $rule (@{ $hardware->{rules} }) { | ||||
| 17752 | 428 | 843 | next if $rule->{deny}; | ||||
| 17753 | 165 | 284 | next if $rule->{prt}->{established}; | ||||
| 17754 | |||||||
| 17755 | # Ignore permit_any_rule of local filter. | ||||||
| 17756 | # Some other permit_any_rule from a real service | ||||||
| 17757 | # wouldn't match. | ||||||
| 17758 | 140 | 312 | next if $local_filter && $rule eq $permit_any_rule; | ||||
| 17759 | 133 | 116 | my $dst = $rule->{dst}; | ||||
| 17760 | |||||||
| 17761 | # We only need to check networks: | ||||||
| 17762 | # - subnet/host and interface already have been checked to | ||||||
| 17763 | # have disjoint ip addresses to interfaces of current router. | ||||||
| 17764 | 133 | 187 | if (is_objectgroup($dst)) { | ||||
| 17765 | 1 | 2 | my $elements = $dst->{elements}; | ||||
| 17766 | 1 | 1 | for my $ip_mask ( @$elements ) { | ||||
| 17767 | 3 | 7 | my ($ip, $mask) = split '/', $ip_mask; | ||||
| 17768 | 3 | 7 | next if $mask == 0xffffffff; | ||||
| 17769 | 3 | 4 | $check_intf->($ip, $mask); | ||||
| 17770 | } | ||||||
| 17771 | } | ||||||
| 17772 | elsif (is_network($dst)) { | ||||||
| 17773 | 111 | 196 | if ($dst->{mask} == 0) { | ||||
| 17774 | 17 | 16 | $protect_all = 1; | ||||
| 17775 | |||||||
| 17776 | # debug("Protect all $router->{name}: $hardware->{name}"); | ||||||
| 17777 | 17 | 27 | last RULE; | ||||
| 17778 | } | ||||||
| 17779 | |||||||
| 17780 | 94 94 | 85 128 | my ($ip, $mask) = @{ address($dst, $no_nat_set) }; | ||||
| 17781 | 94 | 159 | $check_intf->($ip, $mask); | ||||
| 17782 | } | ||||||
| 17783 | } | ||||||
| 17784 | |||||||
| 17785 | 280 | 342 | for my $interface (@$interfaces) { | ||||
| 17786 | 818 | 4411 | if ( | ||||
| 17787 | $no_protect{$interface} | ||||||
| 17788 | or not $protect_all | ||||||
| 17789 | and not $need_protect{$interface} | ||||||
| 17790 | |||||||
| 17791 | # Interface with 'no_in_acl' gets 'permit any any' added | ||||||
| 17792 | # and hence needs deny rules. | ||||||
| 17793 | and not $hardware->{no_in_acl} | ||||||
| 17794 | ) | ||||||
| 17795 | { | ||||||
| 17796 | 700 | 824 | next; | ||||
| 17797 | } | ||||||
| 17798 | |||||||
| 17799 | # Ignore 'unnumbered' interfaces. | ||||||
| 17800 | 118 | 272 | if ($interface->{ip} =~ | ||||
| 17801 | /^(?:unnumbered|negotiated|tunnel|bridged)$/) | ||||||
| 17802 | { | ||||||
| 17803 | 0 | 0 | next; | ||||
| 17804 | } | ||||||
| 17805 | 118 | 191 | internal_err("Managed router has short $interface->{name}") | ||||
| 17806 | if $interface->{ip} eq 'short'; | ||||||
| 17807 | |||||||
| 17808 | # IP of other interface may be unknown if dynamic NAT is used. | ||||||
| 17809 | 118 | 231 | if ($interface->{hardware} ne $hardware) { | ||||
| 17810 | 100 | 140 | my $nat_network = | ||||
| 17811 | get_nat_network($interface->{network}, $no_nat_set); | ||||||
| 17812 | 100 | 184 | next if $nat_network->{dynamic}; | ||||
| 17813 | } | ||||||
| 17814 | 118 | 236 | if ( $interface->{redundancy_interfaces} | ||||
| 17815 | and $seen{ $interface->{redundancy_interfaces} }++) | ||||||
| 17816 | { | ||||||
| 17817 | 0 | 0 | next; | ||||
| 17818 | } | ||||||
| 17819 | |||||||
| 17820 | # Protect own interfaces. | ||||||
| 17821 | 118 118 | 101 390 | push @{ $hardware->{intf_rules} }, | ||||
| 17822 | { | ||||||
| 17823 | deny => 1, | ||||||
| 17824 | src => $network_00, | ||||||
| 17825 | dst => $interface, | ||||||
| 17826 | prt => $prt_ip | ||||||
| 17827 | }; | ||||||
| 17828 | } | ||||||
| 17829 | 280 | 1329 | if ($hardware->{crosslink}) { | ||||
| 17830 | 2 | 8 | $hardware->{intf_rules} = []; | ||||
| 17831 | } | ||||||
| 17832 | } | ||||||
| 17833 | |||||||
| 17834 | # ASA and PIX ignore rules for own interfaces. | ||||||
| 17835 | else { | ||||||
| 17836 | 201 | 275 | $hardware->{intf_rules} = []; | ||||
| 17837 | } | ||||||
| 17838 | |||||||
| 17839 | # Concatenate interface rules and ordinary rules. | ||||||
| 17840 | 481 | 502 | my $intf_rules = $hardware->{intf_rules}; | ||||
| 17841 | 481 | 708 | my $all_rules = @$intf_rules? [ @$intf_rules, @$rules ] : $rules; | ||||
| 17842 | 481 | 697 | cisco_acl_line($router, $all_rules, $no_nat_set, $prefix); | ||||
| 17843 | 481 | 604 | return; | ||||
| 17844 | } | ||||||
| 17845 | |||||||
| 17846 | # Parameter: Interface | ||||||
| 17847 | # Analyzes dst of all rules collected at this interface. | ||||||
| 17848 | # Result: | ||||||
| 17849 | # Array reference to list of all networks which are allowed | ||||||
| 17850 | # to pass this interface. | ||||||
| 17851 | sub get_split_tunnel_nets { | ||||||
| 17852 | 4 | 0 | 4 | my ($interface) = @_; | |||
| 17853 | |||||||
| 17854 | 4 | 4 | my %split_tunnel_nets; | ||||
| 17855 | 4 4 4 | 3 5 7 | for my $rule (@{ $interface->{rules} }, @{ $interface->{intf_rules} }) { | ||||
| 17856 | 11 | 16 | next if $rule->{deny}; | ||||
| 17857 | 11 | 15 | my $dst = $rule->{dst}; | ||||
| 17858 | 11 | 12 | my $dst_network = is_network($dst) ? $dst : $dst->{network}; | ||||
| 17859 | |||||||
| 17860 | # Dont add 'any' (resulting from global:permit) | ||||||
| 17861 | # to split_tunnel networks. | ||||||
| 17862 | 11 | 18 | next if $dst_network->{mask} == 0; | ||||
| 17863 | 10 | 20 | $split_tunnel_nets{$dst_network} = $dst_network; | ||||
| 17864 | } | ||||||
| 17865 | 4 5 | 10 14 | return [ sort { $a->{ip} <=> $b->{ip} || $a->{mask} <=> $b->{mask} } | ||||
| 17866 | values %split_tunnel_nets ]; | ||||||
| 17867 | } | ||||||
| 17868 | |||||||
| 17869 | my %asa_vpn_attr_need_value = | ||||||
| 17870 | map { $_ => 1 } | ||||||
| 17871 | qw(banner dns-server default-domain split-dns wins-server address-pools | ||||||
| 17872 | split-tunnel-network-list vpn-filter); | ||||||
| 17873 | |||||||
| 17874 | sub print_asavpn { | ||||||
| 17875 | 3 | 0 | 3 | my ($router) = @_; | |||
| 17876 | 3 | 4 | my $model = $router->{model}; | ||||
| 17877 | 3 | 5 | my $no_nat_set = $router->{hardware}->[0]->{no_nat_set}; | ||||
| 17878 | |||||||
| 17879 | 3 | 2 | my $global_group_name = 'global'; | ||||
| 17880 | 3 | 7 | print <<"EOF"; | ||||
| 17881 | group-policy $global_group_name internal | ||||||
| 17882 | group-policy $global_group_name attributes | ||||||
| 17883 | pfs enable | ||||||
| 17884 | |||||||
| 17885 | EOF | ||||||
| 17886 | |||||||
| 17887 | # Define tunnel group used for single VPN users. | ||||||
| 17888 | 3 | 3 | my $default_tunnel_group = 'VPN-single'; | ||||
| 17889 | 3 | 4 | my $trust_point = $router->{trust_point}; | ||||
| 17890 | |||||||
| 17891 | 3 | 15 | print <<"EOF"; | ||||
| 17892 | tunnel-group $default_tunnel_group type remote-access | ||||||
| 17893 | tunnel-group $default_tunnel_group general-attributes | ||||||
| 17894 | authorization-server-group LOCAL | ||||||
| 17895 | default-group-policy $global_group_name | ||||||
| 17896 | authorization-required | ||||||
| 17897 | username-from-certificate EA | ||||||
| 17898 | tunnel-group $default_tunnel_group ipsec-attributes | ||||||
| 17899 | chain | ||||||
| 17900 | EOF | ||||||
| 17901 | |||||||
| 17902 | 3 | 4 | if ($model->{v8_4}) { | ||||
| 17903 | 0 | 0 | print <<"EOF"; | ||||
| 17904 | ikev1 trust-point $trust_point | ||||||
| 17905 | ikev1 user-authentication none | ||||||
| 17906 | tunnel-group $default_tunnel_group webvpn-attributes | ||||||
| 17907 | authentication certificate | ||||||
| 17908 | EOF | ||||||
| 17909 | } | ||||||
| 17910 | else { | ||||||
| 17911 | 3 | 9 | print <<"EOF"; | ||||
| 17912 | trust-point $trust_point | ||||||
| 17913 | isakmp ikev1-user-authentication none | ||||||
| 17914 | EOF | ||||||
| 17915 | } | ||||||
| 17916 | 3 | 4 | print <<"EOF"; | ||||
| 17917 | tunnel-group-map default-group $default_tunnel_group | ||||||
| 17918 | |||||||
| 17919 | EOF | ||||||
| 17920 | |||||||
| 17921 | my $print_group_policy = sub { | ||||||
| 17922 | 4 | 4 | my ($name, $attributes) = @_; | ||||
| 17923 | 4 | 8 | print "group-policy $name internal\n"; | ||||
| 17924 | 4 | 5 | print "group-policy $name attributes\n"; | ||||
| 17925 | 4 | 12 | for my $key (sort keys %$attributes) { | ||||
| 17926 | 10 | 12 | my $value = $attributes->{$key}; | ||||
| 17927 | 10 | 10 | my $out = $key; | ||||
| 17928 | 10 | 12 | if (defined($value)) { | ||||
| 17929 | 10 | 20 | $out .= ' value' if $asa_vpn_attr_need_value{$key}; | ||||
| 17930 | 10 | 13 | $out .= " $value"; | ||||
| 17931 | } | ||||||
| 17932 | 10 | 22 | print " $out\n"; | ||||
| 17933 | } | ||||||
| 17934 | 3 | 13 | }; | ||||
| 17935 | |||||||
| 17936 | 3 | 4 | my %cert_group_map; | ||||
| 17937 | my %single_cert_map; | ||||||
| 17938 | 3 | 3 | my $user_counter = 0; | ||||
| 17939 | 3 3 | 3 4 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 17940 | 8 | 14 | next if not $interface->{ip} eq 'tunnel'; | ||||
| 17941 | 3 | 3 | my %split_t_cache; | ||||
| 17942 | |||||||
| 17943 | 3 | 5 | if (my $hash = $interface->{id_rules}) { | ||||
| 17944 | 2 | 11 | for my $id (sort keys %$hash) { | ||||
| 17945 | 5 | 6 | my $id_intf = $hash->{$id}; | ||||
| 17946 | 5 | 5 | my $src = $id_intf->{src}; | ||||
| 17947 | 5 | 4 | $user_counter++; | ||||
| 17948 | 5 | 5 | my $pool_name; | ||||
| 17949 | 5 | 8 | my $attributes = { | ||||
| 17950 | 5 | 8 | %{ $router->{radius_attributes} }, | ||||
| 17951 | 5 | 15 | %{ $src->{network}->{radius_attributes} }, | ||||
| 17952 | 5 | 3 | %{ $src->{radius_attributes} }, | ||||
| 17953 | }; | ||||||
| 17954 | |||||||
| 17955 | # Define split tunnel ACL. | ||||||
| 17956 | # Use default value if not defined. | ||||||
| 17957 | 5 | 6 | my $split_tunnel_policy = $attributes->{'split-tunnel-policy'}; | ||||
| 17958 | 5 | 10 | if (not defined $split_tunnel_policy) { | ||||
| 17959 | |||||||
| 17960 | # Do nothing. | ||||||
| 17961 | } | ||||||
| 17962 | elsif ($split_tunnel_policy eq 'tunnelall') { | ||||||
| 17963 | |||||||
| 17964 | # This is the default value. | ||||||
| 17965 | # Prevent new group-policy to be created. | ||||||
| 17966 | 0 | 0 | delete $attributes->{'split-tunnel-policy'}; | ||||
| 17967 | } | ||||||
| 17968 | elsif ($split_tunnel_policy eq 'tunnelspecified') { | ||||||
| 17969 | 1 | 3 | my $split_tunnel_nets = get_split_tunnel_nets($id_intf); | ||||
| 17970 | 1 | 2 | my $acl_name; | ||||
| 17971 | 1 | 3 | if (my $href = $split_t_cache{@$split_tunnel_nets}) { | ||||
| 17972 | CACHED_NETS: | ||||||
| 17973 | 0 | 0 | for my $cached_name (keys %$href) { | ||||
| 17974 | 0 | 0 | my $cached_nets = $href->{$cached_name}; | ||||
| 17975 | 0 | 0 | for (my $i = 0 ; $i < @$cached_nets ; $i++) { | ||||
| 17976 | 0 | 0 | if ($split_tunnel_nets->[$i] ne | ||||
| 17977 | $cached_nets->[$i]) | ||||||
| 17978 | { | ||||||
| 17979 | 0 | 0 | next CACHED_NETS; | ||||
| 17980 | } | ||||||
| 17981 | } | ||||||
| 17982 | 0 | 0 | $acl_name = $cached_name; | ||||
| 17983 | 0 | 0 | last; | ||||
| 17984 | } | ||||||
| 17985 | } | ||||||
| 17986 | 1 | 2 | if (not $acl_name) { | ||||
| 17987 | 1 | 1 | $acl_name = "split-tunnel-$user_counter"; | ||||
| 17988 | 1 | 2 | if (@$split_tunnel_nets) { | ||||
| 17989 | 1 | 2 | for my $network (@$split_tunnel_nets) { | ||||
| 17990 | 4 | 6 | my $line = | ||||
| 17991 | "access-list $acl_name standard permit "; | ||||||
| 17992 | 4 | 5 | $line .= | ||||
| 17993 | cisco_acl_addr(address($network, | ||||||
| 17994 | $no_nat_set), | ||||||
| 17995 | $model); | ||||||
| 17996 | 4 | 10 | print "$line\n"; | ||||
| 17997 | } | ||||||
| 17998 | } | ||||||
| 17999 | else { | ||||||
| 18000 | 0 | 0 | print "access-list $acl_name standard deny any\n"; | ||||
| 18001 | } | ||||||
| 18002 | 1 | 3 | $split_t_cache{@$split_tunnel_nets}->{$acl_name} = | ||||
| 18003 | $split_tunnel_nets; | ||||||
| 18004 | } | ||||||
| 18005 | 1 | 2 | $attributes->{'split-tunnel-network-list'} = $acl_name; | ||||
| 18006 | } | ||||||
| 18007 | |||||||
| 18008 | # Access list will be bound to cleartext interface. | ||||||
| 18009 | # Only check for valid source address at vpn-filter. | ||||||
| 18010 | 5 | 7 | $id_intf->{intf_rules} = []; | ||||
| 18011 | 5 | 11 | $id_intf->{rules} = [ | ||||
| 18012 | { | ||||||
| 18013 | src => $src, | ||||||
| 18014 | dst => $network_00, | ||||||
| 18015 | prt => $prt_ip, | ||||||
| 18016 | } | ||||||
| 18017 | ]; | ||||||
| 18018 | 5 | 12 | find_object_groups($router, $id_intf); | ||||
| 18019 | |||||||
| 18020 | # Define filter ACL to be used in username or group-policy. | ||||||
| 18021 | 5 | 7 | my $filter_name = "vpn-filter-$user_counter"; | ||||
| 18022 | 5 | 8 | my $prefix = "access-list $filter_name extended"; | ||||
| 18023 | 5 | 9 | print_cisco_acl_add_deny $router, $id_intf, $no_nat_set, $model, | ||||
| 18024 | $prefix; | ||||||
| 18025 | |||||||
| 18026 | 5 | 5 | my $ip = print_ip $src->{ip}; | ||||
| 18027 | 5 | 5 | my $network = $src->{network}; | ||||
| 18028 | 5 | 14 | if ($src->{mask} == 0xffffffff) { | ||||
| 18029 | |||||||
| 18030 | # For anyconnect clients. | ||||||
| 18031 | 3 | 6 | if ($model->{v8_4}) { | ||||
| 18032 | 0 | 0 | my ($name, $domain) = ($id =~ /^(.*?)(\@.*)$/); | ||||
| 18033 | 0 | 0 | $single_cert_map{$domain} = 1; | ||||
| 18034 | } | ||||||
| 18035 | |||||||
| 18036 | 3 | 4 | my $mask = print_ip $network->{mask}; | ||||
| 18037 | 3 | 3 | my $group_policy_name; | ||||
| 18038 | 3 | 6 | if (%$attributes) { | ||||
| 18039 | 2 | 2 | $group_policy_name = "VPN-group-$user_counter"; | ||||
| 18040 | 2 | 3 | $print_group_policy->($group_policy_name, $attributes); | ||||
| 18041 | } | ||||||
| 18042 | 3 | 8 | print "username $id nopassword\n"; | ||||
| 18043 | 3 | 5 | print "username $id attributes\n"; | ||||
| 18044 | 3 | 6 | print " vpn-framed-ip-address $ip $mask\n"; | ||||
| 18045 | 3 | 4 | print " service-type remote-access\n"; | ||||
| 18046 | 3 | 5 | print " vpn-filter value $filter_name\n"; | ||||
| 18047 | 3 | 7 | print " vpn-group-policy $group_policy_name\n" | ||||
| 18048 | if $group_policy_name; | ||||||
| 18049 | 3 | 9 | print "\n"; | ||||
| 18050 | } | ||||||
| 18051 | else { | ||||||
| 18052 | 2 | 4 | $pool_name = "pool-$user_counter"; | ||||
| 18053 | 2 | 3 | my $mask = print_ip $src->{mask}; | ||||
| 18054 | 2 | 4 | my $max = | ||||
| 18055 | print_ip($src->{ip} | complement_32bit $src->{mask}); | ||||||
| 18056 | 2 | 2 | my $subject_name = delete $attributes->{'check-subject-name'}; | ||||
| 18057 | 2 | 7 | if ($id =~ /^@/) { | ||||
| 18058 | 1 | 2 | $subject_name = 'ea'; | ||||
| 18059 | } | ||||||
| 18060 | 2 | 3 | my $map_name = "ca-map-$user_counter"; | ||||
| 18061 | 2 | 4 | print "crypto ca certificate map $map_name 10\n"; | ||||
| 18062 | 2 | 5 | print " subject-name attr $subject_name co $id\n"; | ||||
| 18063 | 2 | 9 | print "ip local pool $pool_name $ip-$max mask $mask\n"; | ||||
| 18064 | 2 | 3 | $attributes->{'vpn-filter'} = $filter_name; | ||||
| 18065 | 2 | 2 | $attributes->{'address-pools'} = $pool_name; | ||||
| 18066 | 2 | 3 | my $group_policy_name = "VPN-group-$user_counter"; | ||||
| 18067 | 2 | 4 | my @tunnel_gen_att = | ||||
| 18068 | ("default-group-policy $group_policy_name"); | ||||||
| 18069 | |||||||
| 18070 | # Select attributes for tunnel-group general-attributes. | ||||||
| 18071 | 2 | 9 | for my $key (sort keys %$attributes) { | ||||
| 18072 | 10 | 9 | my $spec = $asa_vpn_attributes{$key}; | ||||
| 18073 | 10 | 28 | if ($spec && $spec->{tg_general}) { | ||||
| 18074 | 0 | 0 | my $value = delete $attributes->{$key}; | ||||
| 18075 | 0 | 0 | my $out = defined($value) ? "$key $value" : $key; | ||||
| 18076 | 0 | 0 | push(@tunnel_gen_att, $out); | ||||
| 18077 | } | ||||||
| 18078 | } | ||||||
| 18079 | |||||||
| 18080 | 2 | 7 | my $trustpoint2 = delete $attributes->{'trust-point'} | ||||
| 18081 | || $trust_point; | ||||||
| 18082 | 2 | 6 | my @tunnel_ipsec_att = | ||||
| 18083 | $model->{v8_4} | ||||||
| 18084 | ? ( | ||||||
| 18085 | "ikev1 trust-point $trustpoint2", | ||||||
| 18086 | 'ikev1 user-authentication none' | ||||||
| 18087 | ) | ||||||
| 18088 | : ( | ||||||
| 18089 | "trust-point $trustpoint2", | ||||||
| 18090 | 'isakmp ikev1-user-authentication none' | ||||||
| 18091 | ); | ||||||
| 18092 | |||||||
| 18093 | 2 | 4 | $print_group_policy->($group_policy_name, $attributes); | ||||
| 18094 | |||||||
| 18095 | 2 | 3 | my $tunnel_group_name = "VPN-tunnel-$user_counter"; | ||||
| 18096 | 2 | 5 | print <<"EOF"; | ||||
| 18097 | tunnel-group $tunnel_group_name type remote-access | ||||||
| 18098 | tunnel-group $tunnel_group_name general-attributes | ||||||
| 18099 | EOF | ||||||
| 18100 | |||||||
| 18101 | 2 | 2 | for my $line (@tunnel_gen_att) { | ||||
| 18102 | 2 | 5 | print " $line\n"; | ||||
| 18103 | } | ||||||
| 18104 | 2 | 4 | print <<"EOF"; | ||||
| 18105 | tunnel-group $tunnel_group_name ipsec-attributes | ||||||
| 18106 | EOF | ||||||
| 18107 | |||||||
| 18108 | 2 | 1 | for my $line (@tunnel_ipsec_att) { | ||||
| 18109 | 4 | 9 | print " $line\n"; | ||||
| 18110 | } | ||||||
| 18111 | |||||||
| 18112 | # For anyconnect clients. | ||||||
| 18113 | 2 | 4 | if ($model->{v8_4}) { | ||||
| 18114 | 0 | 0 | print <<"EOF"; | ||||
| 18115 | tunnel-group $tunnel_group_name webvpn-attributes | ||||||
| 18116 | authentication certificate | ||||||
| 18117 | EOF | ||||||
| 18118 | 0 | 0 | $cert_group_map{$map_name} = $tunnel_group_name; | ||||
| 18119 | } | ||||||
| 18120 | |||||||
| 18121 | 2 | 9 | print <<"EOF"; | ||||
| 18122 | tunnel-group-map ca-map-$user_counter 10 $tunnel_group_name | ||||||
| 18123 | |||||||
| 18124 | EOF | ||||||
| 18125 | } | ||||||
| 18126 | } | ||||||
| 18127 | } | ||||||
| 18128 | |||||||
| 18129 | # A VPN network. | ||||||
| 18130 | else { | ||||||
| 18131 | 1 | 1 | $user_counter++; | ||||
| 18132 | |||||||
| 18133 | # Access list will be bound to cleartext interface. | ||||||
| 18134 | # Only check for correct source address at vpn-filter. | ||||||
| 18135 | 1 | 2 | $interface->{intf_rules} = []; | ||||
| 18136 | 2 | 5 | $interface->{rules} = [ | ||||
| 18137 | map { | ||||||
| 18138 | 1 | 3 | { | ||||
| 18139 | src => $_, | ||||||
| 18140 | dst => $network_00, | ||||||
| 18141 | prt => $prt_ip, | ||||||
| 18142 | } | ||||||
| 18143 | 1 | 1 | } @{ $interface->{peer_networks} } | ||||
| 18144 | ]; | ||||||
| 18145 | 1 | 3 | find_object_groups($router, $interface); | ||||
| 18146 | |||||||
| 18147 | # Define filter ACL to be used in username or group-policy. | ||||||
| 18148 | 1 | 3 | my $filter_name = "vpn-filter-$user_counter"; | ||||
| 18149 | 1 | 2 | my $prefix = "access-list $filter_name extended"; | ||||
| 18150 | |||||||
| 18151 | 1 | 2 | print_cisco_acl_add_deny $router, $interface, $no_nat_set, $model, | ||||
| 18152 | $prefix; | ||||||
| 18153 | |||||||
| 18154 | 1 | 3 | my $id = $interface->{peers}->[0]->{id} | ||||
| 18155 | or internal_err("Missing ID at $interface->{peers}->[0]->{name}"); | ||||||
| 18156 | 1 | 2 | my $attributes = $router->{radius_attributes}; | ||||
| 18157 | |||||||
| 18158 | 1 | 1 | my $group_policy_name; | ||||
| 18159 | 1 | 3 | if (keys %$attributes) { | ||||
| 18160 | 0 | 0 | $group_policy_name = "VPN-router-$user_counter"; | ||||
| 18161 | 0 | 0 | $print_group_policy->($group_policy_name, $attributes); | ||||
| 18162 | } | ||||||
| 18163 | 1 | 3 | print "username $id nopassword\n"; | ||||
| 18164 | 1 | 2 | print "username $id attributes\n"; | ||||
| 18165 | 1 | 5 | print " service-type remote-access\n"; | ||||
| 18166 | 1 | 2 | print " vpn-filter value $filter_name\n"; | ||||
| 18167 | 1 | 3 | print " vpn-group-policy $group_policy_name\n" | ||||
| 18168 | if $group_policy_name; | ||||||
| 18169 | 1 | 3 | print "\n"; | ||||
| 18170 | } | ||||||
| 18171 | } | ||||||
| 18172 | |||||||
| 18173 | # Generate certificate-group-map for anyconnect/ikev2 clients. | ||||||
| 18174 | 3 | 15 | if (keys %cert_group_map or keys %single_cert_map) { | ||||
| 18175 | 0 | 0 | for my $id (sort keys %single_cert_map) { | ||||
| 18176 | 0 | 0 | $user_counter++; | ||||
| 18177 | 0 | 0 | my $map_name = "ca-map-$user_counter"; | ||||
| 18178 | 0 | 0 | print "crypto ca certificate map $map_name 10\n"; | ||||
| 18179 | 0 | 0 | print " subject-name attr ea co $id\n"; | ||||
| 18180 | 0 | 0 | $cert_group_map{$map_name} = $default_tunnel_group; | ||||
| 18181 | } | ||||||
| 18182 | 0 | 0 | print "webvpn\n"; | ||||
| 18183 | 0 | 0 | for my $map_name (sort keys %cert_group_map) { | ||||
| 18184 | 0 | 0 | my $tunnel_group_map = $cert_group_map{$map_name}; | ||||
| 18185 | 0 | 0 | print " certificate-group-map $map_name 10 $tunnel_group_map\n"; | ||||
| 18186 | } | ||||||
| 18187 | } | ||||||
| 18188 | 3 | 15 | return; | ||||
| 18189 | } | ||||||
| 18190 | |||||||
| 18191 | sub iptables_acl_line { | ||||||
| 18192 | 53 | 0 | 60 | my ($rule, $no_nat_set, $prefix) = @_; | |||
| 18193 | 53 | 98 | my ($action, $src, $dst, $src_range, $prt) = | ||||
| 18194 | 53 | 43 | @{$rule}{qw(action src dst src_range prt)}; | ||||
| 18195 | 53 | 68 | my $spair = address($src, $no_nat_set); | ||||
| 18196 | 53 | 64 | my $dpair = address($dst, $no_nat_set); | ||||
| 18197 | 53 | 70 | my $action_code = | ||||
| 18198 | is_chain($action) ? $action->{name} | ||||||
| 18199 | : $action eq 'permit' ? 'ACCEPT' | ||||||
| 18200 | : 'droplog'; | ||||||
| 18201 | 53 | 79 | my $jump = $rule->{goto} ? '-g' : '-j'; | ||||
| 18202 | 53 | 127 | my $result = "$prefix $jump $action_code"; | ||||
| 18203 | 53 | 111 | if ($spair->[1] != 0) { | ||||
| 18204 | 35 | 48 | $result .= ' -s ' . prefix_code($spair); | ||||
| 18205 | } | ||||||
| 18206 | 53 | 97 | if ($dpair->[1] != 0) { | ||||
| 18207 | 42 | 52 | $result .= ' -d ' . prefix_code($dpair); | ||||
| 18208 | } | ||||||
| 18209 | 53 | 118 | if ($prt ne $prt_ip) { | ||||
| 18210 | 49 | 65 | $result .= ' ' . iptables_prt_code($src_range, $prt); | ||||
| 18211 | } | ||||||
| 18212 | 53 | 103 | print "$result\n"; | ||||
| 18213 | 53 | 159 | return; | ||||
| 18214 | } | ||||||
| 18215 | |||||||
| 18216 | # Pre-processing for all interfaces. | ||||||
| 18217 | sub print_acl_prefix { | ||||||
| 18218 | 246 | 0 | 1263 | my ($router) = @_; | |||
| 18219 | 246 | 263 | my $model = $router->{model}; | ||||
| 18220 | 246 | 474 | return if $model->{filter} ne 'iptables'; | ||||
| 18221 | 33 | 30 | my $comment_char = $model->{comment_char}; | ||||
| 18222 | 33 | 56 | print "$comment_char [ PREFIX ]\n"; | ||||
| 18223 | 33 | 41 | print "#!/sbin/iptables-restore <<EOF\n"; | ||||
| 18224 | |||||||
| 18225 | # Excempt loopback packets from connection tracking. | ||||||
| 18226 | 33 | 34 | print "*raw\n"; | ||||
| 18227 | 33 | 36 | print ":PREROUTING ACCEPT\n"; | ||||
| 18228 | 33 | 33 | print ":OUTPUT ACCEPT\n"; | ||||
| 18229 | 33 | 36 | print "-A PREROUTING -i lo -j NOTRACK\n"; | ||||
| 18230 | 33 | 36 | print "-A OUTPUT -o lo -j NOTRACK\n"; | ||||
| 18231 | 33 | 28 | print "COMMIT\n"; | ||||
| 18232 | |||||||
| 18233 | # Start filter table | ||||||
| 18234 | 33 | 29 | print "*filter\n"; | ||||
| 18235 | 33 | 34 | print ":INPUT DROP\n"; | ||||
| 18236 | 33 | 31 | print ":FORWARD DROP\n"; | ||||
| 18237 | 33 | 33 | print ":OUTPUT ACCEPT\n"; | ||||
| 18238 | 33 | 36 | print "-A INPUT -j ACCEPT -m state --state ESTABLISHED,RELATED\n"; | ||||
| 18239 | 33 | 33 | print "-A FORWARD -j ACCEPT -m state --state ESTABLISHED,RELATED\n"; | ||||
| 18240 | 33 | 33 | print "-A INPUT -j ACCEPT -i lo\n"; | ||||
| 18241 | |||||||
| 18242 | # Add user defined chain 'droplog'. | ||||||
| 18243 | 33 | 32 | print ":droplog -\n"; | ||||
| 18244 | 33 | 37 | print "-A droplog -j LOG --log-level debug\n"; | ||||
| 18245 | 33 | 30 | print "-A droplog -j DROP\n"; | ||||
| 18246 | 33 | 29 | print "\n"; | ||||
| 18247 | 33 | 37 | return; | ||||
| 18248 | } | ||||||
| 18249 | |||||||
| 18250 | sub print_acl_suffix { | ||||||
| 18251 | 246 | 0 | 249 | my ($router) = @_; | |||
| 18252 | 246 | 260 | my $model = $router->{model}; | ||||
| 18253 | 246 | 489 | return if $model->{filter} ne 'iptables'; | ||||
| 18254 | 33 | 32 | my $comment_char = $model->{comment_char}; | ||||
| 18255 | 33 | 52 | print "$comment_char [ SUFFIX ]\n"; | ||||
| 18256 | 33 | 33 | print "-A INPUT -j droplog\n"; | ||||
| 18257 | 33 | 34 | print "-A FORWARD -j droplog\n"; | ||||
| 18258 | 33 | 30 | print "COMMIT\n"; | ||||
| 18259 | 33 | 30 | print "EOF\n"; | ||||
| 18260 | 33 | 31 | return; | ||||
| 18261 | } | ||||||
| 18262 | |||||||
| 18263 | sub print_iptables_acls { | ||||||
| 18264 | 34 | 0 | 34 | my ($router) = @_; | |||
| 18265 | 34 | 32 | my $model = $router->{model}; | ||||
| 18266 | 34 | 29 | my $comment_char = $model->{comment_char}; | ||||
| 18267 | |||||||
| 18268 | 34 | 48 | print_chains $router; | ||||
| 18269 | |||||||
| 18270 | 34 34 | 27 50 | for my $hardware (@{ $router->{hardware} }) { | ||||
| 18271 | |||||||
| 18272 | # Ignore if all logical interfaces are loopback interfaces. | ||||||
| 18273 | 60 | 98 | next if $hardware->{loopback}; | ||||
| 18274 | |||||||
| 18275 | 58 | 67 | my $in_hw = $hardware->{name}; | ||||
| 18276 | 58 | 53 | my $no_nat_set = $hardware->{no_nat_set}; | ||||
| 18277 | 58 | 98 | if ($config{comment_acls}) { | ||||
| 18278 | |||||||
| 18279 | # Name of first logical interface | ||||||
| 18280 | 0 | 0 | print "$comment_char $hardware->{interfaces}->[0]->{name}\n"; | ||||
| 18281 | } | ||||||
| 18282 | |||||||
| 18283 | # Print chain and declaration for interface rules. | ||||||
| 18284 | # Add call to chain in INPUT chain. | ||||||
| 18285 | 58 | 85 | my $intf_acl_name = "${in_hw}_self"; | ||||
| 18286 | 58 | 108 | print ":$intf_acl_name -\n"; | ||||
| 18287 | 58 | 118 | print "-A INPUT -j $intf_acl_name -i $in_hw\n"; | ||||
| 18288 | 58 | 77 | my $intf_prefix = "-A $intf_acl_name"; | ||||
| 18289 | 58 58 | 50 98 | for my $rule (@{ $hardware->{intf_rules} }) { | ||||
| 18290 | 28 | 39 | iptables_acl_line($rule, $no_nat_set, $intf_prefix); | ||||
| 18291 | } | ||||||
| 18292 | |||||||
| 18293 | # Print chain and declaration for forward rules. | ||||||
| 18294 | # Add call to chain in FORRWARD chain. | ||||||
| 18295 | # One chain for each pair of in_intf / out_intf. | ||||||
| 18296 | 58 | 55 | my $rules_hash = $hardware->{io_rules}; | ||||
| 18297 | 58 | 131 | for my $out_hw (sort keys %$rules_hash) { | ||||
| 18298 | 22 | 32 | my $acl_name = "${in_hw}_$out_hw"; | ||||
| 18299 | 22 | 43 | print ":$acl_name -\n"; | ||||
| 18300 | 22 | 57 | print "-A FORWARD -j $acl_name -i $in_hw -o $out_hw\n"; | ||||
| 18301 | 22 | 31 | my $prefix = "-A $acl_name"; | ||||
| 18302 | 22 | 30 | my $rules_aref = $rules_hash->{$out_hw}; | ||||
| 18303 | 22 | 26 | for my $rule (@$rules_aref) { | ||||
| 18304 | 25 | 41 | iptables_acl_line($rule, $no_nat_set, $prefix, $model); | ||||
| 18305 | } | ||||||
| 18306 | } | ||||||
| 18307 | |||||||
| 18308 | # Empty line after each chain. | ||||||
| 18309 | 58 | 117 | print "\n"; | ||||
| 18310 | } | ||||||
| 18311 | 34 | 47 | return; | ||||
| 18312 | } | ||||||
| 18313 | |||||||
| 18314 | sub print_cisco_acls { | ||||||
| 18315 | 214 | 0 | 193 | my ($router) = @_; | |||
| 18316 | 214 | 220 | my $model = $router->{model}; | ||||
| 18317 | 214 | 208 | my $filter = $model->{filter}; | ||||
| 18318 | 214 | 195 | my $comment_char = $model->{comment_char}; | ||||
| 18319 | |||||||
| 18320 | 214 214 | 174 305 | for my $hardware (@{ $router->{hardware} }) { | ||||
| 18321 | |||||||
| 18322 | # Ignore if all logical interfaces are loopback interfaces. | ||||||
| 18323 | 499 | 820 | next if $hardware->{loopback}; | ||||
| 18324 | |||||||
| 18325 | # Ignore layer3 interface of ASA. | ||||||
| 18326 | 486 | 935 | next if $hardware->{name} eq 'device' && $model->{class} eq 'ASA'; | ||||
| 18327 | |||||||
| 18328 | # Force valid array reference to prevent error | ||||||
| 18329 | # when checking for non empty array. | ||||||
| 18330 | 481 | 782 | $hardware->{rules} ||= []; | ||||
| 18331 | |||||||
| 18332 | 481 | 713 | if ($model->{can_objectgroup}) { | ||||
| 18333 | 244 | 361 | if (not $router->{no_group_code}) { | ||||
| 18334 | 244 | 416 | find_object_groups($router, $hardware); | ||||
| 18335 | } | ||||||
| 18336 | } | ||||||
| 18337 | |||||||
| 18338 | 481 | 447 | my $no_nat_set = $hardware->{no_nat_set}; | ||||
| 18339 | |||||||
| 18340 | # Generate code for incoming and possibly for outgoing ACL. | ||||||
| 18341 | 481 | 490 | for my $suffix ('in', 'out') { | ||||
| 18342 | 962 | 2969 | next if $suffix eq 'out' and not $hardware->{need_out_acl}; | ||||
| 18343 | |||||||
| 18344 | # Don't generate single 'permit ip any any'. | ||||||
| 18345 | 496 | 806 | if (!$model->{need_acl}) { | ||||
| 18346 | 289 578 | 296 930 | if (!grep { my $rules = $hardware->{$_} || []; | ||||
| 18347 | 578 | 1772 | @$rules != 1 || $rules->[0] ne $permit_any_rule } | ||||
| 18348 | (qw(rules intf_rules))) | ||||||
| 18349 | { | ||||||
| 18350 | 8 | 8 | next; | ||||
| 18351 | } | ||||||
| 18352 | } | ||||||
| 18353 | |||||||
| 18354 | 488 | 1008 | my $acl_name = "$hardware->{name}_$suffix"; | ||||
| 18355 | 488 | 456 | my $prefix; | ||||
| 18356 | 488 | 782 | if ($config{comment_acls}) { | ||||
| 18357 | |||||||
| 18358 | # Name of first logical interface | ||||||
| 18359 | 0 | 0 | print "$comment_char $hardware->{interfaces}->[0]->{name}\n"; | ||||
| 18360 | } | ||||||
| 18361 | 488 | 1017 | if ($filter eq 'IOS') { | ||||
| 18362 | 246 | 221 | $prefix = ''; | ||||
| 18363 | 246 | 492 | print "ip access-list extended $acl_name\n"; | ||||
| 18364 | } | ||||||
| 18365 | elsif ($filter eq 'NX-OS') { | ||||||
| 18366 | 27 | 27 | $prefix = ''; | ||||
| 18367 | 27 | 69 | print "ip access-list $acl_name\n"; | ||||
| 18368 | } | ||||||
| 18369 | elsif ($filter eq 'ACE') { | ||||||
| 18370 | 8 | 16 | $prefix = "access-list $acl_name extended"; | ||||
| 18371 | } | ||||||
| 18372 | elsif ($filter eq 'PIX') { | ||||||
| 18373 | 207 | 209 | $prefix = "access-list $acl_name"; | ||||
| 18374 | 207 | 434 | $prefix .= ' extended' if $model->{class} eq 'ASA'; | ||||
| 18375 | } | ||||||
| 18376 | |||||||
| 18377 | # Incoming ACL and protect own interfaces. | ||||||
| 18378 | 488 | 630 | if ($suffix eq 'in') { | ||||
| 18379 | 473 | 675 | print_cisco_acl_add_deny( | ||||
| 18380 | $router, $hardware, $no_nat_set, $model, $prefix | ||||||
| 18381 | ); | ||||||
| 18382 | } | ||||||
| 18383 | |||||||
| 18384 | # Outgoing ACL | ||||||
| 18385 | else { | ||||||
| 18386 | 15 | 32 | my $out_rules = $hardware->{out_rules} ||= []; | ||||
| 18387 | |||||||
| 18388 | # Add deny rule at end of ACL if not 'permit ip any any' | ||||||
| 18389 | 15 | 46 | if (!(@$out_rules && $out_rules->[-1] eq $permit_any_rule)) { | ||||
| 18390 | 14 | 17 | push(@$out_rules, $deny_any_rule); | ||||
| 18391 | } | ||||||
| 18392 | 15 | 23 | cisco_acl_line($router, $out_rules, $no_nat_set, $prefix); | ||||
| 18393 | } | ||||||
| 18394 | |||||||
| 18395 | # Post-processing for hardware interface | ||||||
| 18396 | 488 | 1509 | if ($filter eq 'IOS' || $filter eq 'NX-OS') { | ||||
| 18397 | 273 | 921 | push( | ||||
| 18398 | 273 | 235 | @{ $hardware->{subcmd} }, | ||||
| 18399 | "ip access-group $acl_name $suffix" | ||||||
| 18400 | ); | ||||||
| 18401 | } | ||||||
| 18402 | elsif ($filter eq 'ACE') { | ||||||
| 18403 | 8 | 25 | push( | ||||
| 18404 | 8 | 9 | @{ $hardware->{subcmd} }, | ||||
| 18405 | "access-group ${suffix}put $acl_name" | ||||||
| 18406 | ); | ||||||
| 18407 | } | ||||||
| 18408 | elsif ($filter eq 'PIX') { | ||||||
| 18409 | 207 | 712 | print "access-group $acl_name $suffix interface", | ||||
| 18410 | " $hardware->{name}\n"; | ||||||
| 18411 | } | ||||||
| 18412 | |||||||
| 18413 | # Empty line after each ACL. | ||||||
| 18414 | 488 | 794 | print "\n"; | ||||
| 18415 | } | ||||||
| 18416 | } | ||||||
| 18417 | 214 | 272 | return; | ||||
| 18418 | } | ||||||
| 18419 | |||||||
| 18420 | sub print_acls { | ||||||
| 18421 | 248 | 0 | 221 | my ($router) = @_; | |||
| 18422 | 248 | 241 | my $model = $router->{model}; | ||||
| 18423 | 248 | 253 | my $filter = $model->{filter}; | ||||
| 18424 | 248 | 236 | my $comment_char = $model->{comment_char}; | ||||
| 18425 | 248 | 340 | print_header($router, 'ACL'); | ||||
| 18426 | |||||||
| 18427 | 248 | 344 | if ($filter eq 'iptables') { | ||||
| 18428 | 34 | 47 | print_iptables_acls($router); | ||||
| 18429 | } | ||||||
| 18430 | else { | ||||||
| 18431 | 214 | 278 | print_cisco_acls($router); | ||||
| 18432 | } | ||||||
| 18433 | 248 | 435 | return; | ||||
| 18434 | } | ||||||
| 18435 | |||||||
| 18436 | sub gen_crypto_rules { | ||||||
| 18437 | 10 | 0 | 9 | my ($local, $remote) = @_; | |||
| 18438 | 10 | 8 | my @crypto_rules; | ||||
| 18439 | 10 | 11 | for my $src (@$local) { | ||||
| 18440 | 11 | 9 | for my $dst (@$remote) { | ||||
| 18441 | 14 | 44 | push( | ||||
| 18442 | @crypto_rules, | ||||||
| 18443 | { | ||||||
| 18444 | src => $src, | ||||||
| 18445 | dst => $dst, | ||||||
| 18446 | prt => $prt_ip | ||||||
| 18447 | } | ||||||
| 18448 | ); | ||||||
| 18449 | } | ||||||
| 18450 | } | ||||||
| 18451 | 10 | 17 | return \@crypto_rules; | ||||
| 18452 | } | ||||||
| 18453 | |||||||
| 18454 | sub print_ezvpn { | ||||||
| 18455 | 1 | 0 | 1 | my ($router) = @_; | |||
| 18456 | 1 | 2 | my $model = $router->{model}; | ||||
| 18457 | 1 1 | 1 2 | my @interfaces = @{ $router->{interfaces} }; | ||||
| 18458 | 1 4 | 1 7 | my @tunnel_intf = grep { $_->{ip} eq 'tunnel' } @interfaces; | ||||
| 18459 | 1 | 2 | @tunnel_intf == 1 or internal_err(); | ||||
| 18460 | 1 | 2 | my ($tunnel_intf) = @tunnel_intf; | ||||
| 18461 | 1 | 1 | my $wan_intf = $tunnel_intf->{real_interface}; | ||||
| 18462 | 1 | 1 | my $wan_hw = $wan_intf->{hardware}; | ||||
| 18463 | 1 | 2 | my $no_nat_set = $wan_hw->{no_nat_set}; | ||||
| 18464 | 1 4 | 1 15 | my @lan_intf = grep { $_ ne $wan_intf and $_ ne $tunnel_intf } @interfaces; | ||||
| 18465 | |||||||
| 18466 | # Ezvpn configuration. | ||||||
| 18467 | 1 | 2 | my $ezvpn_name = 'vpn'; | ||||
| 18468 | 1 | 1 | my $crypto_acl_name = 'ACL-Split-Tunnel'; | ||||
| 18469 | 1 | 1 | my $crypto_filter_name = 'ACL-crypto-filter'; | ||||
| 18470 | 1 | 1 | my $virtual_interface_number = 1; | ||||
| 18471 | 1 | 3 | print "crypto ipsec client ezvpn $ezvpn_name\n"; | ||||
| 18472 | 1 | 1 | print " connect auto\n"; | ||||
| 18473 | 1 | 1 | print " mode network-extension\n"; | ||||
| 18474 | |||||||
| 18475 | 1 1 | 1 2 | for my $peer (@{ $tunnel_intf->{peers} }) { | ||||
| 18476 | |||||||
| 18477 | # Unnumbered, negotiated and short interfaces have been | ||||||
| 18478 | # rejected already. | ||||||
| 18479 | 1 | 3 | my $peer_ip = prefix_code(address($peer->{real_interface}, | ||||
| 18480 | $no_nat_set)); | ||||||
| 18481 | 1 | 4 | print " peer $peer_ip\n"; | ||||
| 18482 | } | ||||||
| 18483 | |||||||
| 18484 | # Bind split tunnel ACL. | ||||||
| 18485 | 1 | 2 | print " acl $crypto_acl_name\n"; | ||||
| 18486 | |||||||
| 18487 | # Use virtual template defined above. | ||||||
| 18488 | 1 | 3 | print " virtual-interface $virtual_interface_number\n"; | ||||
| 18489 | |||||||
| 18490 | # xauth is unused, but syntactically needed. | ||||||
| 18491 | 1 | 1 | print " username test pass test\n"; | ||||
| 18492 | 1 | 1 | print " xauth userid mode local\n"; | ||||
| 18493 | |||||||
| 18494 | # Apply ezvpn to WAN and LAN interface. | ||||||
| 18495 | 1 | 2 | for my $lan_intf (@lan_intf) { | ||||
| 18496 | 2 | 3 | my $lan_hw = $lan_intf->{hardware}; | ||||
| 18497 | 2 | 6 | push( | ||||
| 18498 | 2 | 1 | @{ $lan_hw->{subcmd} }, | ||||
| 18499 | "crypto ipsec client ezvpn $ezvpn_name inside" | ||||||
| 18500 | ); | ||||||
| 18501 | } | ||||||
| 18502 | 1 1 | 1 3 | push(@{ $wan_hw->{subcmd} }, "crypto ipsec client ezvpn $ezvpn_name"); | ||||
| 18503 | |||||||
| 18504 | # Crypto ACL controls which traffic needs to be encrypted. | ||||||
| 18505 | 1 | 3 | $tunnel_intf->{crypto}->{detailed_crypto_acl} | ||||
| 18506 | and internal_err("Unexpected attribute 'detailed_crypto_acl'", | ||||||
| 18507 | " at $router->{name}"); | ||||||
| 18508 | 1 | 3 | my $crypto_rules = | ||||
| 18509 | gen_crypto_rules($tunnel_intf->{peers}->[0]->{peer_networks}, | ||||||
| 18510 | [$network_00]); | ||||||
| 18511 | 1 | 3 | print "ip access-list extended $crypto_acl_name\n"; | ||||
| 18512 | 1 | 1 | my $prefix = ''; | ||||
| 18513 | 1 | 2 | cisco_acl_line($router, $crypto_rules, $no_nat_set, $prefix); | ||||
| 18514 | |||||||
| 18515 | # Crypto filter ACL. | ||||||
| 18516 | 1 | 1 | $prefix = ''; | ||||
| 18517 | 1 | 3 | $tunnel_intf->{intf_rules} ||= []; | ||||
| 18518 | 1 | 7 | $tunnel_intf->{rules} ||= []; | ||||
| 18519 | 1 | 2 | print "ip access-list extended $crypto_filter_name\n"; | ||||
| 18520 | 1 | 2 | print_cisco_acl_add_deny($router, $tunnel_intf, $no_nat_set, $model, | ||||
| 18521 | $prefix); | ||||||
| 18522 | |||||||
| 18523 | # Bind crypto filter ACL to virtual template. | ||||||
| 18524 | 1 | 2 | print "interface Virtual-Template$virtual_interface_number type tunnel\n"; | ||||
| 18525 | 1 | 4 | $crypto_filter_name | ||||
| 18526 | and print " ip access-group $crypto_filter_name in\n"; | ||||||
| 18527 | 1 | 3 | return; | ||||
| 18528 | } | ||||||
| 18529 | |||||||
| 18530 | # Print crypto ACL. | ||||||
| 18531 | # It controls which traffic needs to be encrypted. | ||||||
| 18532 | sub print_crypto_acl { | ||||||
| 18533 | 9 | 0 | 10 | my ($interface, $suffix, $crypto, $crypto_type) = @_; | |||
| 18534 | 9 | 12 | my $crypto_acl_name = "crypto-$suffix"; | ||||
| 18535 | 9 | 8 | my $prefix; | ||||
| 18536 | 9 | 17 | if ($crypto_type eq 'IOS') { | ||||
| 18537 | 1 | 1 | $prefix = ''; | ||||
| 18538 | 1 | 3 | print "ip access-list extended $crypto_acl_name\n"; | ||||
| 18539 | } | ||||||
| 18540 | elsif ($crypto_type eq 'ASA') { | ||||||
| 18541 | 8 | 15 | $prefix = "access-list $crypto_acl_name extended"; | ||||
| 18542 | } | ||||||
| 18543 | else { | ||||||
| 18544 | 0 | 0 | internal_err(); | ||||
| 18545 | } | ||||||
| 18546 | |||||||
| 18547 | # Print crypto ACL entries. | ||||||
| 18548 | # - either generic from remote network to any or | ||||||
| 18549 | # - detailed to all networks which are used in rules. | ||||||
| 18550 | 9 | 9 | my $is_hub = $interface->{is_hub}; | ||||
| 18551 | 9 | 13 | my $hub = $is_hub ? $interface : $interface->{peers}->[0]; | ||||
| 18552 | 9 | 10 | my $detailed = $crypto->{detailed_crypto_acl}; | ||||
| 18553 | 9 | 15 | my $local = $detailed ? get_split_tunnel_nets($hub) : [$network_00]; | ||||
| 18554 | 9 | 8 | my $remote = $hub->{peer_networks}; | ||||
| 18555 | 9 | 18 | $is_hub or ($local, $remote) = ($remote, $local); | ||||
| 18556 | 9 | 11 | my $crypto_rules = gen_crypto_rules($local, $remote); | ||||
| 18557 | 9 | 11 | my $router = $interface->{router}; | ||||
| 18558 | 9 | 7 | my $no_nat_set = $interface->{no_nat_set}; | ||||
| 18559 | 9 | 14 | cisco_acl_line($router, $crypto_rules, $no_nat_set, $prefix); | ||||
| 18560 | 9 | 24 | return $crypto_acl_name; | ||||
| 18561 | } | ||||||
| 18562 | |||||||
| 18563 | # Print filter ACL. It controls which traffic is allowed to leave from | ||||||
| 18564 | # crypto tunnel. This may be needed, if we don't fully trust our peer. | ||||||
| 18565 | sub print_crypto_filter_acl { | ||||||
| 18566 | 9 | 0 | 11 | my ($interface, $suffix, $crypto_type) = @_; | |||
| 18567 | 9 | 9 | my $router = $interface->{router}; | ||||
| 18568 | |||||||
| 18569 | 9 | 17 | return if $router->{no_crypto_filter}; | ||||
| 18570 | |||||||
| 18571 | 1 | 2 | my $prefix; | ||||
| 18572 | 1 | 2 | my $crypto_filter_name = "crypto-filter-$suffix"; | ||||
| 18573 | 1 | 2 | if ($crypto_type eq 'IOS') { | ||||
| 18574 | 1 | 1 | $prefix = ''; | ||||
| 18575 | 1 | 3 | print "ip access-list extended $crypto_filter_name\n"; | ||||
| 18576 | } | ||||||
| 18577 | else { | ||||||
| 18578 | 0 | 0 | internal_err(); | ||||
| 18579 | } | ||||||
| 18580 | 1 | 2 | my $model = $router->{model}; | ||||
| 18581 | 1 | 1 | my $no_nat_set = $interface->{no_nat_set}; | ||||
| 18582 | 1 | 2 | print_cisco_acl_add_deny($router, $interface, $no_nat_set, $model, $prefix); | ||||
| 18583 | 1 | 6 | return $crypto_filter_name; | ||||
| 18584 | } | ||||||
| 18585 | |||||||
| 18586 | # Called for static and dynamic crypto maps. | ||||||
| 18587 | sub print_crypto_map_attributes { | ||||||
| 18588 | 9 | 0 | 16 | my ($prefix, $model, $crypto_type, $crypto_acl_name, $crypto_filter_name, | |||
| 18589 | $isakmp, $ipsec, $ipsec2trans_name) = @_; | ||||||
| 18590 | |||||||
| 18591 | # Bind crypto ACL to crypto map. | ||||||
| 18592 | 9 | 20 | print "$prefix match address $crypto_acl_name\n"; | ||||
| 18593 | |||||||
| 18594 | # Bind crypto filter ACL to crypto map. | ||||||
| 18595 | 9 | 18 | if ($crypto_filter_name) { | ||||
| 18596 | 1 | 3 | print "$prefix set ip access-group $crypto_filter_name in\n"; | ||||
| 18597 | } | ||||||
| 18598 | |||||||
| 18599 | 9 | 12 | my $transform_name = $ipsec2trans_name->{$ipsec}; | ||||
| 18600 | 9 | 13 | if ($crypto_type eq 'ASA') { | ||||
| 18601 | 8 | 18 | if ($isakmp->{ike_version} == 2) { | ||||
| 18602 | 2 | 5 | print "$prefix set ikev2 ipsec-proposal $transform_name\n"; | ||||
| 18603 | } | ||||||
| 18604 | elsif ($model->{v8_4}) { | ||||||
| 18605 | 2 | 5 | print "$prefix set ikev1 transform-set $transform_name\n"; | ||||
| 18606 | } | ||||||
| 18607 | else { | ||||||
| 18608 | 4 | 9 | print "$prefix set transform-set $transform_name\n"; | ||||
| 18609 | } | ||||||
| 18610 | } | ||||||
| 18611 | else { | ||||||
| 18612 | 1 | 2 | print "$prefix set transform-set $transform_name\n"; | ||||
| 18613 | } | ||||||
| 18614 | |||||||
| 18615 | 9 | 24 | if (my $pfs_group = $ipsec->{pfs_group}) { | ||||
| 18616 | 9 | 20 | print "$prefix set pfs group$pfs_group\n"; | ||||
| 18617 | } | ||||||
| 18618 | |||||||
| 18619 | 9 | 18 | if (my $lifetime = $ipsec->{lifetime}) { | ||||
| 18620 | |||||||
| 18621 | # Don't print default value for backend IOS. | ||||||
| 18622 | 9 | 24 | if (not($lifetime == 3600 and $crypto_type eq 'IOS')) { | ||||
| 18623 | 8 | 23 | print("$prefix set security-association", | ||||
| 18624 | " lifetime seconds $lifetime\n"); | ||||||
| 18625 | } | ||||||
| 18626 | } | ||||||
| 18627 | 9 | 12 | return; | ||||
| 18628 | } | ||||||
| 18629 | |||||||
| 18630 | sub print_tunnel_group { | ||||||
| 18631 | 8 | 0 | 9 | my ($name, $interface, $isakmp) = @_; | |||
| 18632 | 8 | 8 | my $model = $interface->{router}->{model}; | ||||
| 18633 | 8 | 8 | my $no_nat_set = $interface->{no_nat_set}; | ||||
| 18634 | 8 | 8 | my $authentication = $isakmp->{authentication}; | ||||
| 18635 | 8 | 18 | print "tunnel-group $name type ipsec-l2l\n"; | ||||
| 18636 | 8 | 14 | print "tunnel-group $name ipsec-attributes\n"; | ||||
| 18637 | 8 | 11 | if ($authentication eq 'rsasig') { | ||||
| 18638 | 6 | 7 | my $trust_point = $isakmp->{trust_point}; | ||||
| 18639 | 6 | 12 | if ($isakmp->{ike_version} == 2) { | ||||
| 18640 | 2 | 5 | print(" ikev2 local-authentication certificate", | ||||
| 18641 | " $trust_point\n"); | ||||||
| 18642 | 2 | 3 | print(" ikev2 remote-authentication certificate\n"); | ||||
| 18643 | } | ||||||
| 18644 | elsif ($model->{v8_4}) { | ||||||
| 18645 | 2 | 5 | print " ikev1 trust-point $trust_point\n"; | ||||
| 18646 | 2 | 4 | print " ikev1 user-authentication none\n"; | ||||
| 18647 | } | ||||||
| 18648 | else { | ||||||
| 18649 | 2 | 5 | print " trust-point $trust_point\n"; | ||||
| 18650 | 2 | 3 | print " isakmp ikev1-user-authentication none\n"; | ||||
| 18651 | } | ||||||
| 18652 | } | ||||||
| 18653 | |||||||
| 18654 | # Preshared key is configured manually. | ||||||
| 18655 | else { | ||||||
| 18656 | 2 | 3 | print " peer-id-validate nocheck\n"; | ||||
| 18657 | } | ||||||
| 18658 | 8 | 14 | return; | ||||
| 18659 | } | ||||||
| 18660 | |||||||
| 18661 | sub print_ca_and_tunnel_group_map { | ||||||
| 18662 | 6 | 0 | 5 | my ($id, $tg_name) = @_; | |||
| 18663 | |||||||
| 18664 | # Activate tunnel-group with tunnel-group-map. | ||||||
| 18665 | # Use $id as ca-map name. | ||||||
| 18666 | 6 | 13 | print "crypto ca certificate map $id 10\n"; | ||||
| 18667 | 6 | 11 | print " subject-name attr ea eq $id\n"; | ||||
| 18668 | 6 | 14 | print "tunnel-group-map $id 10 $tg_name\n"; | ||||
| 18669 | 6 | 16 | return; | ||||
| 18670 | } | ||||||
| 18671 | |||||||
| 18672 | sub print_static_crypto_map { | ||||||
| 18673 | 5 | 0 | 8 | my ($router, $hardware, $map_name, $interfaces, $ipsec2trans_name) = @_; | |||
| 18674 | 5 | 5 | my $model = $router->{model}; | ||||
| 18675 | 5 | 5 | my $crypto_type = $model->{crypto}; | ||||
| 18676 | 5 | 6 | my $hw_name = $hardware->{name}; | ||||
| 18677 | |||||||
| 18678 | # Sequence number for parts of crypto map with different peers. | ||||||
| 18679 | 5 | 5 | my $seq_num = 0; | ||||
| 18680 | |||||||
| 18681 | # Crypto ACLs and peer IP must obey NAT. | ||||||
| 18682 | 5 | 4 | my $no_nat_set = $hardware->{no_nat_set}; | ||||
| 18683 | |||||||
| 18684 | # Sort crypto maps by peer IP to get deterministic output. | ||||||
| 18685 | 5 2 | 8 7 | my @sorted = sort({ $a->{peers}->[0]->{real_interface}->{ip} | ||||
| 18686 | <=> | ||||||
| 18687 | $b->{peers}->[0]->{real_interface}->{ip} | ||||||
| 18688 | } | ||||||
| 18689 | @$interfaces); | ||||||
| 18690 | |||||||
| 18691 | # Build crypto map for each tunnel interface. | ||||||
| 18692 | 5 | 6 | for my $interface (@sorted) { | ||||
| 18693 | 7 | 7 | $seq_num++; | ||||
| 18694 | 7 | 15 | my $suffix = "$hw_name-$seq_num"; | ||||
| 18695 | |||||||
| 18696 | 7 | 8 | my $crypto = $interface->{crypto}; | ||||
| 18697 | 7 | 8 | my $ipsec = $crypto->{type}; | ||||
| 18698 | 7 | 7 | my $isakmp = $ipsec->{key_exchange}; | ||||
| 18699 | |||||||
| 18700 | 7 | 10 | my $crypto_acl_name = print_crypto_acl($interface, $suffix, $crypto, | ||||
| 18701 | $crypto_type); | ||||||
| 18702 | 7 | 11 | my $crypto_filter_name = print_crypto_filter_acl($interface, $suffix, | ||||
| 18703 | $crypto_type); | ||||||
| 18704 | |||||||
| 18705 | |||||||
| 18706 | # Define crypto map. | ||||||
| 18707 | 7 | 6 | my $prefix; | ||||
| 18708 | 7 | 15 | if ($crypto_type eq 'IOS') { | ||||
| 18709 | 1 | 2 | $prefix = ''; | ||||
| 18710 | 1 | 8 | print "crypto map $map_name $seq_num ipsec-isakmp\n"; | ||||
| 18711 | } | ||||||
| 18712 | elsif ($crypto_type eq 'ASA') { | ||||||
| 18713 | 6 | 14 | $prefix = "crypto map $map_name $seq_num"; | ||||
| 18714 | } | ||||||
| 18715 | |||||||
| 18716 | # Set crypto peers. | ||||||
| 18717 | 7 | 15 | if ($crypto_type eq 'IOS') { | ||||
| 18718 | 1 1 | 1 1 | for my $peer (@{ $interface->{peers} }) { | ||||
| 18719 | 1 | 2 | my $peer_ip = prefix_code(address($peer->{real_interface}, | ||||
| 18720 | $no_nat_set)); | ||||||
| 18721 | 1 | 4 | print "$prefix set peer $peer_ip\n"; | ||||
| 18722 | } | ||||||
| 18723 | } | ||||||
| 18724 | elsif ($crypto_type eq 'ASA') { | ||||||
| 18725 | 6 | 12 | print "$prefix set peer ", | ||||
| 18726 | join(' ', | ||||||
| 18727 | 6 | 7 | map { prefix_code(address($_->{real_interface}, | ||||
| 18728 | $no_nat_set)) } | ||||||
| 18729 | 6 | 8 | @{ $interface->{peers} }), | ||||
| 18730 | "\n"; | ||||||
| 18731 | } | ||||||
| 18732 | |||||||
| 18733 | 7 | 13 | print_crypto_map_attributes($prefix, $model, $crypto_type, | ||||
| 18734 | $crypto_acl_name, $crypto_filter_name, | ||||||
| 18735 | $isakmp, $ipsec, $ipsec2trans_name); | ||||||
| 18736 | |||||||
| 18737 | |||||||
| 18738 | 7 | 12 | if ($crypto_type eq 'ASA') { | ||||
| 18739 | 6 6 | 4 11 | for my $peer (@{ $interface->{peers} }) { | ||||
| 18740 | 6 | 10 | my $peer_ip = prefix_code(address($peer->{real_interface}, | ||||
| 18741 | $no_nat_set)); | ||||||
| 18742 | 6 | 10 | print_tunnel_group($peer_ip, $interface, $isakmp); | ||||
| 18743 | |||||||
| 18744 | # Tunnel group needs to be activated, if certificate | ||||||
| 18745 | # is in use. | ||||||
| 18746 | 6 | 16 | if (my $id = $peer->{id}) { | ||||
| 18747 | 4 | 6 | print_ca_and_tunnel_group_map($id, $peer_ip); | ||||
| 18748 | } | ||||||
| 18749 | } | ||||||
| 18750 | } | ||||||
| 18751 | } | ||||||
| 18752 | 5 | 7 | return; | ||||
| 18753 | } | ||||||
| 18754 | |||||||
| 18755 | sub print_dynamic_crypto_map { | ||||||
| 18756 | 1 | 0 | 2 | my ($router, $hardware, $map_name, $interfaces, $ipsec2trans_name) = @_; | |||
| 18757 | 1 | 1 | my $model = $router->{model}; | ||||
| 18758 | 1 | 2 | my $crypto_type = $model->{crypto}; | ||||
| 18759 | 1 | 2 | $crypto_type eq 'ASA' or internal_err(); | ||||
| 18760 | 1 | 2 | my $hw_name = $hardware->{name}; | ||||
| 18761 | |||||||
| 18762 | # Sequence number for parts of crypto map with different certificates. | ||||||
| 18763 | 1 | 1 | my $seq_num = 65536; | ||||
| 18764 | |||||||
| 18765 | # Sort crypto maps by certificate to get deterministic output. | ||||||
| 18766 | 1 1 | 2 3 | my @sorted = sort({ $a->{peers}->[0]->{id} cmp $b->{peers}->[0]->{id} } | ||||
| 18767 | @$interfaces); | ||||||
| 18768 | |||||||
| 18769 | # Build crypto map for each tunnel interface. | ||||||
| 18770 | 1 | 2 | for my $interface (@sorted) { | ||||
| 18771 | 2 | 2 | $seq_num--; | ||||
| 18772 | 2 | 5 | my $suffix = "$hw_name-$seq_num"; | ||||
| 18773 | 2 | 4 | my $id = $interface->{peers}->[0]->{id}; | ||||
| 18774 | |||||||
| 18775 | 2 | 2 | my $crypto = $interface->{crypto}; | ||||
| 18776 | 2 | 2 | my $ipsec = $crypto->{type}; | ||||
| 18777 | 2 | 2 | my $isakmp = $ipsec->{key_exchange}; | ||||
| 18778 | |||||||
| 18779 | 2 | 4 | my $crypto_acl_name = print_crypto_acl($interface, $suffix, $crypto, | ||||
| 18780 | $crypto_type); | ||||||
| 18781 | 2 | 3 | my $crypto_filter_name = print_crypto_filter_acl($interface, $suffix, | ||||
| 18782 | $crypto_type); | ||||||
| 18783 | |||||||
| 18784 | # Define dynamic crypto map. | ||||||
| 18785 | # Use certificate as name. | ||||||
| 18786 | 2 | 5 | my $prefix = "crypto dynamic-map $id 10"; | ||||
| 18787 | |||||||
| 18788 | 2 | 3 | print_crypto_map_attributes($prefix, $model, $crypto_type, | ||||
| 18789 | $crypto_acl_name, $crypto_filter_name, | ||||||
| 18790 | $isakmp, $ipsec, $ipsec2trans_name); | ||||||
| 18791 | |||||||
| 18792 | # Bind dynamic crypto map to crypto map. | ||||||
| 18793 | 2 | 5 | $prefix = "crypto map $map_name $seq_num"; | ||||
| 18794 | 2 | 5 | print "$prefix ipsec-isakmp dynamic $id\n"; | ||||
| 18795 | |||||||
| 18796 | # Use $id as tunnel-group name | ||||||
| 18797 | 2 | 3 | print_tunnel_group($id, $interface, $isakmp); | ||||
| 18798 | |||||||
| 18799 | # Activate tunnel-group with tunnel-group-map. | ||||||
| 18800 | 2 | 3 | print_ca_and_tunnel_group_map($id, $id); | ||||
| 18801 | } | ||||||
| 18802 | 1 | 2 | return; | ||||
| 18803 | } | ||||||
| 18804 | |||||||
| 18805 | sub print_crypto { | ||||||
| 18806 | 248 | 0 | 228 | my ($router) = @_; | |||
| 18807 | 248 | 604 | my $model = $router->{model}; | ||||
| 18808 | 248 | 534 | my $crypto_type = $model->{crypto} || ''; | ||||
| 18809 | |||||||
| 18810 | # List of ipsec definitions used at current router. | ||||||
| 18811 | # Sort entries by name to get deterministic output. | ||||||
| 18812 | 13 | 24 | my @ipsec = sort by_name unique( | ||||
| 18813 | 612 | 1969 | map { $_->{crypto}->{type} } | ||||
| 18814 | 248 248 | 250 338 | grep { $_->{ip} eq 'tunnel' } @{ $router->{interfaces} } | ||||
| 18815 | ); | ||||||
| 18816 | |||||||
| 18817 | # Return if no crypto is used at current router. | ||||||
| 18818 | 248 | 727 | return unless @ipsec; | ||||
| 18819 | |||||||
| 18820 | # List of isakmp definitions used at current router. | ||||||
| 18821 | # Sort entries by name to get deterministic output. | ||||||
| 18822 | 10 13 | 11 21 | my @isakmp = sort by_name unique(map { $_->{key_exchange} } @ipsec); | ||||
| 18823 | |||||||
| 18824 | 10 | 12 | my $comment_char = $model->{comment_char}; | ||||
| 18825 | 10 | 12 | print_header($router, 'Crypto'); | ||||
| 18826 | |||||||
| 18827 | 10 | 19 | if ($crypto_type eq 'EZVPN') { | ||||
| 18828 | 1 | 3 | print_ezvpn $router; | ||||
| 18829 | 1 | 3 | return; | ||||
| 18830 | } | ||||||
| 18831 | |||||||
| 18832 | # Use interface access lists to filter incoming crypto traffic. | ||||||
| 18833 | # Group policy and per-user authorization access list can't be used | ||||||
| 18834 | # because they are stateless. | ||||||
| 18835 | 9 | 25 | if ($crypto_type =~ /^ASA/) { | ||||
| 18836 | 8 | 11 | print "! VPN traffic is filtered at interface ACL\n"; | ||||
| 18837 | 8 | 10 | print "no sysopt connection permit-vpn\n"; | ||||
| 18838 | } | ||||||
| 18839 | |||||||
| 18840 | 9 | 17 | if ($crypto_type eq 'ASA_VPN') { | ||||
| 18841 | 3 | 7 | print_asavpn $router; | ||||
| 18842 | 3 | 7 | return; | ||||
| 18843 | } | ||||||
| 18844 | |||||||
| 18845 | # Crypto config for ASA as EZVPN client is configured manually once. | ||||||
| 18846 | # No config is generated by netspoc. | ||||||
| 18847 | 6 | 8 | if ($crypto_type eq 'ASA_EZVPN') { | ||||
| 18848 | 0 | 0 | return; | ||||
| 18849 | } | ||||||
| 18850 | |||||||
| 18851 | 6 | 20 | $crypto_type =~ /^(:?IOS|ASA)$/ | ||||
| 18852 | or internal_err("Unexptected crypto type $crypto_type"); | ||||||
| 18853 | |||||||
| 18854 | 6 | 6 | my $isakmp_count = 0; | ||||
| 18855 | 6 | 9 | for my $isakmp (@isakmp) { | ||||
| 18856 | |||||||
| 18857 | # Only print isakmp for IOS. Approve for ASA will ignore it anyway. | ||||||
| 18858 | 9 | 18 | $crypto_type eq 'IOS' or next; | ||||
| 18859 | |||||||
| 18860 | 1 | 2 | $isakmp_count++; | ||||
| 18861 | 1 | 3 | print "crypto isakmp policy $isakmp_count\n"; | ||||
| 18862 | |||||||
| 18863 | 1 | 1 | my $authentication = $isakmp->{authentication}; | ||||
| 18864 | 1 | 2 | $authentication =~ s/preshare/pre-share/; | ||||
| 18865 | 1 | 4 | $authentication =~ s/rsasig/rsa-sig/; | ||||
| 18866 | |||||||
| 18867 | # Don't print default value for backend IOS. | ||||||
| 18868 | 1 | 3 | if (not($authentication eq 'rsa-sig')) { | ||||
| 18869 | 0 | 0 | print " authentication $authentication\n"; | ||||
| 18870 | } | ||||||
| 18871 | |||||||
| 18872 | 1 | 2 | my $encryption = $isakmp->{encryption}; | ||||
| 18873 | 1 | 5 | if ($encryption =~ /^aes(\d+)$/) { | ||||
| 18874 | 1 | 4 | my $len = $crypto_type eq 'ASA' ? "-$1" : " $1"; | ||||
| 18875 | 1 | 2 | $encryption = "aes$len"; | ||||
| 18876 | } | ||||||
| 18877 | 1 | 2 | print " encryption $encryption\n"; | ||||
| 18878 | 1 | 2 | my $hash = $isakmp->{hash}; | ||||
| 18879 | 1 | 2 | print " hash $hash\n"; | ||||
| 18880 | 1 | 2 | my $group = $isakmp->{group}; | ||||
| 18881 | 1 | 2 | print " group $group\n"; | ||||
| 18882 | |||||||
| 18883 | 1 | 1 | my $lifetime = $isakmp->{lifetime}; | ||||
| 18884 | |||||||
| 18885 | # Don't print default value for backend IOS. | ||||||
| 18886 | 1 | 3 | if (not($lifetime == 86400)) { | ||||
| 18887 | 1 | 3 | print " lifetime $lifetime\n"; | ||||
| 18888 | } | ||||||
| 18889 | } | ||||||
| 18890 | |||||||
| 18891 | # Handle IPSEC definition. | ||||||
| 18892 | 6 | 6 | my $transform_count = 0; | ||||
| 18893 | 6 | 7 | my %ipsec2trans_name; | ||||
| 18894 | 6 | 7 | for my $ipsec (@ipsec) { | ||||
| 18895 | 9 | 7 | $transform_count++; | ||||
| 18896 | 9 | 15 | my $transform_name = "Trans$transform_count"; | ||||
| 18897 | 9 | 12 | $ipsec2trans_name{$ipsec} = $transform_name; | ||||
| 18898 | 9 | 10 | my $isakmp = $ipsec->{key_exchange}; | ||||
| 18899 | |||||||
| 18900 | # IKEv2 syntax for ASA. | ||||||
| 18901 | 9 | 30 | if ($crypto_type eq 'ASA' and $isakmp->{ike_version} == 2) { | ||||
| 18902 | 2 | 5 | print "crypto ipsec ikev2 ipsec-proposal $transform_name\n"; | ||||
| 18903 | 2 | 11 | if (my $ah = $ipsec->{ah}) { | ||||
| 18904 | 0 | 0 | print " protocol ah $ah\n"; | ||||
| 18905 | } | ||||||
| 18906 | 2 | 2 | my $esp_encr; | ||||
| 18907 | 2 | 16 | if (not(my $esp = $ipsec->{esp_encryption})) { | ||||
| 18908 | 0 | 0 | $esp_encr = 'null'; | ||||
| 18909 | } | ||||||
| 18910 | elsif ($esp =~ /^(aes|des|3des)$/) { | ||||||
| 18911 | 0 | 0 | $esp_encr = $1; | ||||
| 18912 | } | ||||||
| 18913 | elsif ($esp =~ /^aes(192|256)$/) { | ||||||
| 18914 | 2 | 4 | $esp_encr = "aes-$1"; | ||||
| 18915 | } | ||||||
| 18916 | 2 | 4 | print " protocol esp encryption $esp_encr\n"; | ||||
| 18917 | 2 | 5 | if (my $esp_ah = $ipsec->{esp_authentication}) { | ||||
| 18918 | 2 | 9 | $esp_ah =~ s/^(.+?)(\d+)/$1-$2/; | ||||
| 18919 | 2 | 9 | print " protocol esp integrity $esp_ah\n"; | ||||
| 18920 | } | ||||||
| 18921 | } | ||||||
| 18922 | |||||||
| 18923 | # IKEv1 syntax of ASA is identical to IOS. | ||||||
| 18924 | else { | ||||||
| 18925 | 7 | 11 | my $transform = ''; | ||||
| 18926 | 7 | 10 | if (my $ah = $ipsec->{ah}) { | ||||
| 18927 | 0 | 0 | $transform .= "ah-$ah-hmac "; | ||||
| 18928 | } | ||||||
| 18929 | 7 | 41 | if (not(my $esp = $ipsec->{esp_encryption})) { | ||||
| 18930 | 0 | 0 | $transform .= 'esp-null '; | ||||
| 18931 | } | ||||||
| 18932 | elsif ($esp =~ /^(aes|des|3des)$/) { | ||||||
| 18933 | 3 | 7 | $transform .= "esp-$1 "; | ||||
| 18934 | } | ||||||
| 18935 | elsif ($esp =~ /^aes(192|256)$/) { | ||||||
| 18936 | 4 | 10 | my $len = $crypto_type eq 'ASA' ? "-$1" : " $1"; | ||||
| 18937 | 4 | 9 | $transform .= "esp-aes$len "; | ||||
| 18938 | } | ||||||
| 18939 | 7 | 18 | if (my $esp_ah = $ipsec->{esp_authentication}) { | ||||
| 18940 | 7 | 12 | $transform .= "esp-$esp_ah-hmac"; | ||||
| 18941 | } | ||||||
| 18942 | 7 | 24 | my $prefix = ($crypto_type eq 'ASA' and $model->{v8_4}) | ||||
| 18943 | ? 'crypto ipsec ikev1' | ||||||
| 18944 | : 'crypto ipsec'; | ||||||
| 18945 | 7 | 26 | print "$prefix transform-set $transform_name $transform\n"; | ||||
| 18946 | } | ||||||
| 18947 | } | ||||||
| 18948 | |||||||
| 18949 | # Collect tunnel interfaces attached to each hardware interface. | ||||||
| 18950 | # Differentiate on peers having static or dynamic IP address. | ||||||
| 18951 | 6 | 7 | my %hardware2crypto; | ||||
| 18952 | my %hardware2dyn_crypto; | ||||||
| 18953 | 6 6 | 5 9 | for my $interface (@{ $router->{interfaces} }) { | ||||
| 18954 | 21 | 36 | $interface->{ip} eq 'tunnel' or next; | ||||
| 18955 | 9 | 13 | my $ip = $interface->{peers}->[0]->{real_interface}->{ip}; | ||||
| 18956 | 9 | 20 | if ($ip =~ /^(?:negotiated|short|unnumbered)$/) { | ||||
| 18957 | 2 2 | 3 5 | push @{ $hardware2dyn_crypto{ $interface->{hardware} } }, $interface; | ||||
| 18958 | } | ||||||
| 18959 | else { | ||||||
| 18960 | 7 7 | 3 21 | push @{ $hardware2crypto{ $interface->{hardware} } }, $interface; | ||||
| 18961 | } | ||||||
| 18962 | } | ||||||
| 18963 | |||||||
| 18964 | 6 6 | 6 10 | for my $hardware (@{ $router->{hardware} }) { | ||||
| 18965 | 12 | 11 | my $hw_name = $hardware->{name}; | ||||
| 18966 | |||||||
| 18967 | # Name of crypto map. | ||||||
| 18968 | 12 | 13 | my $map_name = "crypto-$hw_name"; | ||||
| 18969 | |||||||
| 18970 | 12 | 12 | my $have_crypto_map; | ||||
| 18971 | 12 | 22 | if (my $interfaces = $hardware2crypto{$hardware}) { | ||||
| 18972 | 5 | 11 | print_static_crypto_map($router, $hardware, $map_name, $interfaces, | ||||
| 18973 | \%ipsec2trans_name); | ||||||
| 18974 | 5 | 4 | $have_crypto_map = 1; | ||||
| 18975 | } | ||||||
| 18976 | 12 | 23 | if (my $interfaces = $hardware2dyn_crypto{$hardware}) { | ||||
| 18977 | 1 | 2 | print_dynamic_crypto_map($router, $hardware, $map_name, $interfaces, | ||||
| 18978 | \%ipsec2trans_name); | ||||||
| 18979 | 1 | 1 | $have_crypto_map = 1; | ||||
| 18980 | } | ||||||
| 18981 | |||||||
| 18982 | # Bind crypto map to interface. | ||||||
| 18983 | 12 | 22 | $have_crypto_map or next; | ||||
| 18984 | 6 | 13 | if ($crypto_type eq 'IOS') { | ||||
| 18985 | 1 1 | 1 4 | push(@{ $hardware->{subcmd} }, "crypto map $map_name"); | ||||
| 18986 | } | ||||||
| 18987 | elsif ($crypto_type eq 'ASA') { | ||||||
| 18988 | 5 | 19 | print "crypto map $map_name interface $hw_name\n"; | ||||
| 18989 | } | ||||||
| 18990 | } | ||||||
| 18991 | 6 | 23 | return; | ||||
| 18992 | } | ||||||
| 18993 | |||||||
| 18994 | sub print_interface { | ||||||
| 18995 | 248 | 0 | 224 | my ($router) = @_; | |||
| 18996 | 248 | 256 | my $model = $router->{model}; | ||||
| 18997 | 248 | 523 | return if !$model->{print_interface}; | ||||
| 18998 | 122 | 134 | my $class = $model->{class}; | ||||
| 18999 | 122 | 151 | my $stateful = not $model->{stateless}; | ||||
| 19000 | 122 122 | 115 174 | for my $hardware (@{ $router->{hardware} }) { | ||||
| 19001 | 291 | 312 | my $name = $hardware->{name}; | ||||
| 19002 | 291 | 515 | next if $name eq 'VIP' and $model->{has_vip}; | ||||
| 19003 | 289 | 227 | my @subcmd; | ||||
| 19004 | my $secondary; | ||||||
| 19005 | 0 | 0 | my $addr_cmd; | ||||
| 19006 | 289 289 | 224 357 | for my $intf (@{ $hardware->{interfaces} }) { | ||||
| 19007 | 319 | 312 | my $ip = $intf->{ip}; | ||||
| 19008 | 319 | 847 | if ($ip eq 'tunnel') { | ||||
| 19009 | 0 | 0 | next; | ||||
| 19010 | } | ||||||
| 19011 | elsif ($ip eq 'unnumbered') { | ||||||
| 19012 | 4 | 5 | $addr_cmd = 'ip unnumbered X'; | ||||
| 19013 | } | ||||||
| 19014 | elsif ($ip eq 'negotiated') { | ||||||
| 19015 | 1 | 1 | $addr_cmd = 'ip address negotiated'; | ||||
| 19016 | } | ||||||
| 19017 | elsif ($model->{use_prefix}) { | ||||||
| 19018 | 37 | 46 | my $addr = print_ip($ip); | ||||
| 19019 | 37 | 61 | my $mask = mask2prefix($intf->{network}->{mask}); | ||||
| 19020 | 37 | 63 | $addr_cmd = "ip address $addr/$mask"; | ||||
| 19021 | 37 | 70 | $addr_cmd .= ' secondary' if $secondary; | ||||
| 19022 | } | ||||||
| 19023 | else { | ||||||
| 19024 | 277 | 338 | my $addr = print_ip($ip); | ||||
| 19025 | 277 | 420 | my $mask = print_ip($intf->{network}->{mask}); | ||||
| 19026 | 277 | 438 | $addr_cmd = "ip address $addr $mask"; | ||||
| 19027 | 277 | 472 | $addr_cmd .= ' secondary' if $secondary; | ||||
| 19028 | } | ||||||
| 19029 | 319 | 307 | push @subcmd, $addr_cmd; | ||||
| 19030 | 319 | 456 | $secondary = 1; | ||||
| 19031 | } | ||||||
| 19032 | 289 | 517 | if (my $vrf = $router->{vrf}) { | ||||
| 19033 | 4 | 6 | if ($class eq 'NX-OS') { | ||||
| 19034 | 4 | 5 | push @subcmd, "vrf member $vrf"; | ||||
| 19035 | } | ||||||
| 19036 | else { | ||||||
| 19037 | 0 | 0 | push @subcmd, "ip vrf forwarding $vrf"; | ||||
| 19038 | } | ||||||
| 19039 | } | ||||||
| 19040 | |||||||
| 19041 | # Add "ip inspect" as marker, that stateful filtering is expected. | ||||||
| 19042 | # The command is known to be incomplete, "X" is only used as | ||||||
| 19043 | # placeholder. | ||||||
| 19044 | 289 | 1172 | if ($class eq 'IOS' && $stateful && !$hardware->{loopback}) { | ||||
| 19045 | 167 | 161 | push @subcmd, "ip inspect X in"; | ||||
| 19046 | } | ||||||
| 19047 | 289 | 469 | if (my $other = $hardware->{subcmd}) { | ||||
| 19048 | 270 | 271 | push @subcmd, @$other; | ||||
| 19049 | } | ||||||
| 19050 | |||||||
| 19051 | # Split name for ACE: "vlan3029" -> "vlan 3029" | ||||||
| 19052 | 289 | 469 | $name =~ s/(\d+)/ $1/ if ($class eq 'ACE'); | ||||
| 19053 | |||||||
| 19054 | 289 | 535 | print "interface $name\n"; | ||||
| 19055 | 289 | 342 | for my $cmd (@subcmd) { | ||||
| 19056 | 775 | 1572 | print " $cmd\n"; | ||||
| 19057 | } | ||||||
| 19058 | } | ||||||
| 19059 | 122 | 150 | print "\n"; | ||||
| 19060 | 122 | 226 | return; | ||||
| 19061 | } | ||||||
| 19062 | |||||||
| 19063 | # Make output directory available. | ||||||
| 19064 | sub check_output_dir { | ||||||
| 19065 | 310 | 0 | 308 | my ($dir) = @_; | |||
| 19066 | 310 | 1249 | unless (-e $dir) { | ||||
| 19067 | 0 | 0 | mkdir $dir | ||||
| 19068 | or fatal_err("Can't create output directory $dir: $!"); | ||||||
| 19069 | } | ||||||
| 19070 | 310 | 792 | -d $dir or fatal_err("$dir isn't a directory"); | ||||
| 19071 | 310 | 322 | return; | ||||
| 19072 | } | ||||||
| 19073 | |||||||
| 19074 | # Print generated code for each managed router. | ||||||
| 19075 | sub print_code { | ||||||
| 19076 | 155 | 0 | 184 | my ($dir) = @_; | |||
| 19077 | |||||||
| 19078 | # Untaint $dir. This is necessary if running setuid. | ||||||
| 19079 | # We can trust value of $dir because it is set by setuid wrapper. | ||||||
| 19080 | 155 | 515 | ($dir) = ($dir =~ /(.*)/); | ||||
| 19081 | 155 | 276 | check_output_dir($dir); | ||||
| 19082 | |||||||
| 19083 | 155 | 201 | progress('Printing code'); | ||||
| 19084 | 155 | 128 | my %seen; | ||||
| 19085 | 155 | 206 | for my $router (@managed_routers, @routing_only_routers) { | ||||
| 19086 | 261 | 543 | next if $seen{$router}; | ||||
| 19087 | |||||||
| 19088 | # Ignore splitted part. | ||||||
| 19089 | 258 | 430 | next if $router->{orig_router}; | ||||
| 19090 | |||||||
| 19091 | 249 | 313 | my $device_name = $router->{device_name}; | ||||
| 19092 | 249 | 211 | my $file = $device_name; | ||||
| 19093 | |||||||
| 19094 | # Untaint $file. It has already been checked for word characters, | ||||||
| 19095 | # but check again for the case of a weird locale setting. | ||||||
| 19096 | 249 | 545 | $file =~ /^(.*)/; | ||||
| 19097 | 249 | 602 | $file = "$dir/$1"; | ||||
| 19098 | |||||||
| 19099 | ## no critic (RequireBriefOpen) | ||||||
| 19100 | 249 | 6126 | open(my $code_fd, '>', $file) | ||||
| 19101 | or fatal_err("Can't open $file for writing: $!"); | ||||||
| 19102 | 249 | 670 | select $code_fd; | ||||
| 19103 | |||||||
| 19104 | 249 | 334 | my $model = $router->{model}; | ||||
| 19105 | 249 | 274 | my $comment_char = $model->{comment_char}; | ||||
| 19106 | |||||||
| 19107 | # Restore interfaces of splitted router. | ||||||
| 19108 | 249 | 443 | if (my $orig_interfaces = $router->{orig_interfaces}) { | ||||
| 19109 | 9 | 10 | $router->{interfaces} = $orig_interfaces; | ||||
| 19110 | 9 | 14 | $router->{hardware} = $router->{orig_hardware}; | ||||
| 19111 | } | ||||||
| 19112 | |||||||
| 19113 | # Collect VRF members. | ||||||
| 19114 | 249 | 185 | my $vrf_members; | ||||
| 19115 | 249 | 394 | if (my $members = $router->{vrf_members}) { | ||||
| 19116 | 3 | 5 | $vrf_members = $members; | ||||
| 19117 | 3 | 14 | $seen{$_} = 1 for @$members; | ||||
| 19118 | } | ||||||
| 19119 | else { | ||||||
| 19120 | 246 | 360 | $vrf_members = [ $router ]; | ||||
| 19121 | } | ||||||
| 19122 | |||||||
| 19123 | 249 | 2036 | print "$comment_char Generated by $program, version $version\n\n"; | ||||
| 19124 | 249 | 571 | print "$comment_char [ BEGIN $device_name ]\n"; | ||||
| 19125 | 249 | 489 | print "$comment_char [ Model = $model->{class} ]\n"; | ||||
| 19126 | 249 | 439 | if ($router->{policy_distribution_point}) { | ||||
| 19127 | 7 7 7 | 11 9 22 | my @ips = map({ my $ips = $_->{admin_ip}; $ips ? @$ips : (); } | ||||
| 19128 | @$vrf_members); | ||||||
| 19129 | 7 | 16 | if (@ips) { | ||||
| 19130 | 7 | 48 | printf("$comment_char [ IP = %s ]\n", join(',', @ips)); | ||||
| 19131 | } | ||||||
| 19132 | } | ||||||
| 19133 | my $per_vrf = sub { | ||||||
| 19134 | 1233 | 1060 | my($call) = @_; | ||||
| 19135 | 1233 | 1292 | for my $vrouter (@$vrf_members) { | ||||
| 19136 | 1244 | 1546 | $call->($vrouter); | ||||
| 19137 | } | ||||||
| 19138 | 249 | 803 | }; | ||||
| 19139 | 249 | 407 | if ($router->{managed}) { | ||||
| 19140 | 246 | 427 | $per_vrf->(\&print_routes); | ||||
| 19141 | 246 | 438 | $per_vrf->(\&print_crypto); | ||||
| 19142 | 246 | 422 | print_acl_prefix($router); | ||||
| 19143 | 246 | 364 | $per_vrf->(\&print_acls); | ||||
| 19144 | 246 | 390 | print_acl_suffix($router); | ||||
| 19145 | 246 | 377 | $per_vrf->(\&print_interface); | ||||
| 19146 | 246 | 387 | $per_vrf->(\&print_nat); | ||||
| 19147 | } | ||||||
| 19148 | else { | ||||||
| 19149 | 3 | 5 | $per_vrf->(\&print_routes); | ||||
| 19150 | } | ||||||
| 19151 | |||||||
| 19152 | 249 | 566 | print "$comment_char [ END $device_name ]\n\n"; | ||||
| 19153 | 249 | 310 | select STDOUT; | ||||
| 19154 | 249 | 5839 | close $code_fd or fatal_err("Can't close $file: $!"); | ||||
| 19155 | ## use critic | ||||||
| 19156 | |||||||
| 19157 | } | ||||||
| 19158 | 155 | 255 | return; | ||||
| 19159 | } | ||||||
| 19160 | |||||||
| 19161 | sub copy_raw { | ||||||
| 19162 | 155 | 0 | 224 | my ($in_path, $out_dir) = @_; | |||
| 19163 | 155 | 939 | return if ! (defined $in_path && -d $in_path); | ||||
| 19164 | 155 | 247 | return if ! defined $out_dir; | ||||
| 19165 | |||||||
| 19166 | # Untaint $in_path, $out_dir. This is necessary if running setuid. | ||||||
| 19167 | # Trusted because set by setuid wrapper. | ||||||
| 19168 | 155 | 515 | ($in_path) = ($in_path =~ /(.*)/); | ||||
| 19169 | 155 | 319 | ($out_dir) = ($out_dir =~ /(.*)/); | ||||
| 19170 | 155 | 232 | check_output_dir($out_dir); | ||||
| 19171 | |||||||
| 19172 | 155 | 236 | my $raw_dir = "$in_path/raw"; | ||||
| 19173 | 155 | 840 | return if not -d $raw_dir; | ||||
| 19174 | |||||||
| 19175 | # Clean PATH if run in taint mode. | ||||||
| 19176 | ## no critic (RequireLocalizedPunctuationVars) | ||||||
| 19177 | 0 | 0 | $ENV{PATH} = '/usr/local/bin:/usr/bin:/bin'; | ||||
| 19178 | ## use critic | ||||||
| 19179 | |||||||
| 19180 | 0 | 0 | my %device_names = | ||||
| 19181 | 0 | 0 | map { $_->{device_name} => 1 } @managed_routers, @routing_only_routers; | ||||
| 19182 | |||||||
| 19183 | 0 | 0 | opendir(my $dh, $raw_dir) or fatal_err("Can't opendir $raw_dir: $!"); | ||||
| 19184 | 0 | 0 | while (my $file = Encode::decode($filename_encode, readdir $dh)) { | ||||
| 19185 | 0 | 0 | next if $file =~ /^\./; | ||||
| 19186 | 0 | 0 | next if $file =~ m/$config{ignore_files}/o; | ||||
| 19187 | |||||||
| 19188 | # Untaint $file. | ||||||
| 19189 | 0 | 0 | my ($raw_file) = ($file =~ /^(.*)/); | ||||
| 19190 | 0 | 0 | my $raw_path = "$raw_dir/$raw_file"; | ||||
| 19191 | 0 | 0 | if (not -f $raw_path) { | ||||
| 19192 | 0 | 0 | warn_msg("Ignoring $raw_path"); | ||||
| 19193 | 0 | 0 | next; | ||||
| 19194 | } | ||||||
| 19195 | 0 | 0 | if (not $device_names{$file}) { | ||||
| 19196 | 0 | 0 | warn_msg("Found unused $raw_path"); | ||||
| 19197 | 0 | 0 | next; | ||||
| 19198 | } | ||||||
| 19199 | 0 | 0 | my $copy = "$out_dir/$raw_file.raw"; | ||||
| 19200 | 0 | 0 | system("cp -f $raw_path $copy") == 0 | ||||
| 19201 | or fatal_err("Can't copy $raw_path to $copy: $!"); | ||||||
| 19202 | } | ||||||
| 19203 | 0 | 0 | return; | ||||
| 19204 | } | ||||||
| 19205 | |||||||
| 19206 | sub show_version { | ||||||
| 19207 | 318 | 0 | 753 | progress("$program, version $version"); | |||
| 19208 | 318 | 298 | return; | ||||
| 19209 | } | ||||||
| 19210 | |||||||
| 19211 | sub show_finished { | ||||||
| 19212 | 208 | 0 | 381 | progress('Finished') if $config{time_stamps}; | |||
| 19213 | 208 | 177 | return; | ||||
| 19214 | } | ||||||
| 19215 | |||||||
| 19216 | # These must be initialized on each run, because protocols are changed | ||||||
| 19217 | # by prepare_prt_ordering. | ||||||
| 19218 | sub init_protocols { | ||||||
| 19219 | |||||||
| 19220 | 375 | 0 | 1229 | %routing_info = ( | |||
| 19221 | EIGRP => { | ||||||
| 19222 | name => 'EIGRP', | ||||||
| 19223 | prt => { name => 'auto_prt:EIGRP', proto => 88 }, | ||||||
| 19224 | mcast => [ | ||||||
| 19225 | new( | ||||||
| 19226 | 'Network', | ||||||
| 19227 | name => "auto_network:EIGRP_multicast", | ||||||
| 19228 | ip => gen_ip(224, 0, 0, 10), | ||||||
| 19229 | mask => gen_ip(255, 255, 255, 255) | ||||||
| 19230 | ) | ||||||
| 19231 | ] | ||||||
| 19232 | }, | ||||||
| 19233 | OSPF => { | ||||||
| 19234 | name => 'OSPF', | ||||||
| 19235 | prt => { name => 'auto_prt:OSPF', proto => 89 }, | ||||||
| 19236 | mcast => [ | ||||||
| 19237 | new( | ||||||
| 19238 | 'Network', | ||||||
| 19239 | name => "auto_network:OSPF_multicast5", | ||||||
| 19240 | ip => gen_ip(224, 0, 0, 5), | ||||||
| 19241 | mask => gen_ip(255, 255, 255, 255), | ||||||
| 19242 | ), | ||||||
| 19243 | new( | ||||||
| 19244 | 'Network', | ||||||
| 19245 | name => "auto_network:OSPF_multicast6", | ||||||
| 19246 | ip => gen_ip(224, 0, 0, 6), | ||||||
| 19247 | mask => gen_ip(255, 255, 255, 255) | ||||||
| 19248 | ) | ||||||
| 19249 | ] | ||||||
| 19250 | }, | ||||||
| 19251 | dynamic => { name => 'dynamic' }, | ||||||
| 19252 | |||||||
| 19253 | # Identical to 'dynamic', but must only be applied to router. | ||||||
| 19254 | manual => { name => 'manual' }, | ||||||
| 19255 | ); | ||||||
| 19256 | 375 | 1159 | %xxrp_info = ( | ||||
| 19257 | VRRP => { | ||||||
| 19258 | prt => { name => 'auto_prt:VRRP', proto => 112 }, | ||||||
| 19259 | mcast => new( | ||||||
| 19260 | 'Network', | ||||||
| 19261 | name => "auto_network:VRRP_multicast", | ||||||
| 19262 | ip => gen_ip(224, 0, 0, 18), | ||||||
| 19263 | mask => gen_ip(255, 255, 255, 255) | ||||||
| 19264 | ) | ||||||
| 19265 | }, | ||||||
| 19266 | HSRP => { | ||||||
| 19267 | prt => { | ||||||
| 19268 | name => 'auto_prt:HSRP', | ||||||
| 19269 | proto => 'udp', | ||||||
| 19270 | dst_range => [ 1985, 1985 ], | ||||||
| 19271 | }, | ||||||
| 19272 | mcast => new( | ||||||
| 19273 | 'Network', | ||||||
| 19274 | name => "auto_network:HSRP_multicast", | ||||||
| 19275 | ip => gen_ip(224, 0, 0, 2), | ||||||
| 19276 | mask => gen_ip(255, 255, 255, 255) | ||||||
| 19277 | ) | ||||||
| 19278 | }, | ||||||
| 19279 | HSRPv2 => { | ||||||
| 19280 | prt => { | ||||||
| 19281 | name => 'auto_prt:HSRPv2', | ||||||
| 19282 | proto => 'udp', | ||||||
| 19283 | dst_range => [ 1985, 1985 ], | ||||||
| 19284 | }, | ||||||
| 19285 | mcast => new( | ||||||
| 19286 | 'Network', | ||||||
| 19287 | name => "auto_network:HSRPv2_multicast", | ||||||
| 19288 | ip => gen_ip(224, 0, 0, 102), | ||||||
| 19289 | mask => gen_ip(255, 255, 255, 255) | ||||||
| 19290 | ) | ||||||
| 19291 | }, | ||||||
| 19292 | ); | ||||||
| 19293 | |||||||
| 19294 | 375 | 836 | $prt_ip = { name => 'auto_prt:ip', proto => 'ip' }; | ||||
| 19295 | 375 | 578 | $prt_icmp = { | ||||
| 19296 | name => 'auto_prt:icmp', | ||||||
| 19297 | proto => 'icmp' | ||||||
| 19298 | }; | ||||||
| 19299 | 375 | 806 | $prt_tcp = { | ||||
| 19300 | name => 'auto_prt:tcp', | ||||||
| 19301 | proto => 'tcp', | ||||||
| 19302 | dst_range => $aref_tcp_any | ||||||
| 19303 | }; | ||||||
| 19304 | 375 | 732 | $prt_udp = { | ||||
| 19305 | name => 'auto_prt:udp', | ||||||
| 19306 | proto => 'udp', | ||||||
| 19307 | dst_range => $aref_tcp_any | ||||||
| 19308 | }; | ||||||
| 19309 | 375 | 869 | $prt_bootps = { | ||||
| 19310 | name => 'auto_prt:bootps', | ||||||
| 19311 | proto => 'udp', | ||||||
| 19312 | dst_range => [ 67, 67] | ||||||
| 19313 | }; | ||||||
| 19314 | 375 | 1082 | $prt_ike = { | ||||
| 19315 | name => 'auto_prt:IPSec_IKE', | ||||||
| 19316 | proto => 'udp', | ||||||
| 19317 | src_range => [ 500, 500 ], | ||||||
| 19318 | dst_range => [ 500, 500 ] | ||||||
| 19319 | }; | ||||||
| 19320 | 375 | 1130 | $prt_natt = { | ||||
| 19321 | name => 'auto_prt:IPSec_NATT', | ||||||
| 19322 | proto => 'udp', | ||||||
| 19323 | src_range => [ 4500, 4500 ], | ||||||
| 19324 | dst_range => [ 4500, 4500 ] | ||||||
| 19325 | }; | ||||||
| 19326 | 375 | 748 | $prt_esp = { name => 'auto_prt:IPSec_ESP', proto => 50, prio => 100, }; | ||||
| 19327 | 375 | 707 | $prt_ah = { name => 'auto_prt:IPSec_AH', proto => 51, prio => 99, }; | ||||
| 19328 | 375 | 801 | $deny_any_rule = { | ||||
| 19329 | deny => 1, | ||||||
| 19330 | src => $network_00, | ||||||
| 19331 | dst => $network_00, | ||||||
| 19332 | prt => $prt_ip | ||||||
| 19333 | }; | ||||||
| 19334 | 375 | 634 | $permit_any_rule = { | ||||
| 19335 | src => $network_00, | ||||||
| 19336 | dst => $network_00, | ||||||
| 19337 | prt => $prt_ip | ||||||
| 19338 | }; | ||||||
| 19339 | 375 | 505 | return; | ||||
| 19340 | } | ||||||
| 19341 | |||||||
| 19342 | sub init_global_vars { | ||||||
| 19343 | 375 | 0 | 813 | $start_time = time(); | |||
| 19344 | 375 | 344 | $error_counter = 0; | ||||
| 19345 | 375 | 343 | $abort_immediately = undef; | ||||
| 19346 | 375 | 320 | $new_store_description = 0; | ||||
| 19347 | 375 | 837 | for my $pair (values %global_type) { | ||||
| 19348 | 4875 4875 | 3331 6494 | %{ $pair->[1] } = (); | ||||
| 19349 | } | ||||||
| 19350 | 375 | 824 | %interfaces = %hosts = (); | ||||
| 19351 | 375 | 578 | @managed_routers = @routing_only_routers = @router_fragments = (); | ||||
| 19352 | 375 | 525 | @virtual_interfaces = @pathrestrictions = (); | ||||
| 19353 | 375 | 730 | @managed_crypto_hubs = @routers = @networks = @zones = @areas = (); | ||||
| 19354 | 375 | 365 | @natdomains = (); | ||||
| 19355 | 375 | 375 | %auto_interfaces = (); | ||||
| 19356 | 375 | 348 | $from_json = undef; | ||||
| 19357 | 375 | 537 | %crypto2spokes = %crypto2hubs = (); | ||||
| 19358 | 375 | 371 | %rule_tree = (); | ||||
| 19359 | 375 | 8419 | %prt_hash = %ref2prt = %ref2obj = %token2regex = (); | ||||
| 19360 | 375 | 438 | %ref2obj = %ref2prt = (); | ||||
| 19361 | 375 | 385 | %obj2zone = (); | ||||
| 19362 | 375 | 366 | %obj2path = (); | ||||
| 19363 | 375 | 341 | %key2obj = (); | ||||
| 19364 | 375 | 353 | %border2obj2auto = (); | ||||
| 19365 | 375 | 351 | %filter_networks = (); | ||||
| 19366 | 375 | 344 | @deleted_rules = (); | ||||
| 19367 | 375 | 451 | %unknown2services = %unknown2unknown = (); | ||||
| 19368 | 375 | 413 | %supernet_rule_tree = %missing_supernet = (); | ||||
| 19369 | 375 | 361 | %smaller_prt = (); | ||||
| 19370 | 375 | 409 | %known_log = %key2log = (); | ||||
| 19371 | 375 | 537 | init_protocols(); | ||||
| 19372 | 375 | 419 | return; | ||||
| 19373 | } | ||||||
| 19374 | |||||||
| 19375 | # Call once when module is loaded. | ||||||
| 19376 | # Call again, before different input is processed by same instance. | ||||||
| 19377 | init_global_vars(); | ||||||
| 19378 | |||||||
| 19379 | #################################################################### | ||||||
| 19380 | # Argument processing | ||||||
| 19381 | # Get option names from %config. | ||||||
| 19382 | # Write options back to %config. | ||||||
| 19383 | #################################################################### | ||||||
| 19384 | |||||||
| 19385 | 70 70 70 | 25307 114 361 | use Getopt::Long qw(GetOptionsFromArray); | ||||
| 19386 | 70 70 70 | 15783 126 62673 | use Pod::Usage; | ||||
| 19387 | |||||||
| 19388 | sub parse_options { | ||||||
| 19389 | 305 | 0 | 260 | my ($args) = @_; | |||
| 19390 | 305 | 245 | my %result; | ||||
| 19391 | my $setopt = sub { | ||||||
| 19392 | 3 | 3 | my ($key, $val) = @_; | ||||
| 19393 | 3 | 6 | if (my $expected = check_config_pair($key, $val)) { | ||||
| 19394 | 0 | 0 | die "Value '$val' invalid for option $key ($expected expected)\n"; | ||||
| 19395 | } | ||||||
| 19396 | 3 | 9 | $result{$key} = $val; | ||||
| 19397 | 305 | 1180 | }; | ||||
| 19398 | |||||||
| 19399 | 305 | 287 | my %options; | ||||
| 19400 | 305 | 429 | for my $key (get_config_keys()) { | ||||
| 19401 | 5185 | 5887 | my $opt = get_config_pattern($key) eq '0|1' ? '!' : '=s'; | ||||
| 19402 | 5185 | 9188 | $options{"$key$opt"} = $setopt; | ||||
| 19403 | } | ||||||
| 19404 | 305 305 | 1147 675 | $options{quiet} = sub { $result{verbose} = 0 }; | ||||
| 19405 | 305 0 | 670 0 | $options{'help|?'} = sub { pod2usage(1) }; | ||||
| 19406 | 305 0 | 642 0 | $options{man} = sub { pod2usage(-exitstatus => 0, -verbose => 2) }; | ||||
| 19407 | |||||||
| 19408 | 305 | 1506 | if (!GetOptionsFromArray($args, %options)) { | ||||
| 19409 | |||||||
| 19410 | # Don't use 'exit' but 'die', so we can catch this error in tests. | ||||||
| 19411 | 0 | 0 | my $out; | ||||
| 19412 | 0 | 0 | open(my $fh, '>', \$out) or die $!; | ||||
| 19413 | 0 | 0 | pod2usage(-exitstatus => 'NOEXIT', -verbose => 0, -output => $fh); | ||||
| 19414 | 0 | 0 | close $fh; | ||||
| 19415 | 0 | 0 | die($out || ''); | ||||
| 19416 | } | ||||||
| 19417 | |||||||
| 19418 | 305 | 2711 | return \%result; | ||||
| 19419 | } | ||||||
| 19420 | |||||||
| 19421 | sub parse_args { | ||||||
| 19422 | 305 | 0 | 279 | my ($args) = @_; | |||
| 19423 | 305 | 350 | my $main_file = shift @$args; | ||||
| 19424 | |||||||
| 19425 | # Strip trailing slash for nicer messages. | ||||||
| 19426 | 305 | 673 | defined $main_file and $main_file =~ s</$><>; | ||||
| 19427 | |||||||
| 19428 | # $out_dir is used to store compilation results. | ||||||
| 19429 | # For each managed router with name X a corresponding file X | ||||||
| 19430 | # is created in $out_dir. | ||||||
| 19431 | # If $out_dir is missing, all code is printed to STDOUT. | ||||||
| 19432 | 305 | 274 | my $out_dir = shift @$args; | ||||
| 19433 | |||||||
| 19434 | # Strip trailing slash for nicer messages. | ||||||
| 19435 | 305 | 493 | defined $out_dir and $out_dir =~ s</$><>; | ||||
| 19436 | |||||||
| 19437 | # No further arguments allowed. | ||||||
| 19438 | 305 | 460 | @$args and pod2usage(2); | ||||
| 19439 | 305 | 534 | return ($main_file, $out_dir); | ||||
| 19440 | } | ||||||
| 19441 | |||||||
| 19442 | sub compile { | ||||||
| 19443 | 305 | 0 | 289 | my ($args) = @_; | |||
| 19444 | |||||||
| 19445 | 305 | 478 | my($cmd_config) = &parse_options($args); | ||||
| 19446 | 305 | 507 | my($in_path, $out_dir) = &parse_args($args); | ||||
| 19447 | 305 | 494 | my $file_config = &read_config($in_path); | ||||
| 19448 | |||||||
| 19449 | # Command line options override options from 'config' file. | ||||||
| 19450 | # Rightmost overrides. | ||||||
| 19451 | 305 | 501 | &set_config($file_config, $cmd_config); | ||||
| 19452 | |||||||
| 19453 | # Don't compile but check only for errors if no $out_dir is given. | ||||||
| 19454 | 305 | 420 | &fast_mode(!$out_dir); | ||||
| 19455 | 305 | 421 | &show_version(); | ||||
| 19456 | 305 | 427 | &read_file_or_dir($in_path); | ||||
| 19457 | 305 | 424 | &show_read_statistics(); | ||||
| 19458 | 305 | 412 | &order_protocols(); | ||||
| 19459 | 305 | 422 | &link_topology(); | ||||
| 19460 | 305 | 441 | &mark_disabled(); | ||||
| 19461 | 305 | 464 | &set_zone(); | ||||
| 19462 | 305 | 441 | &setpath(); | ||||
| 19463 | 300 | 422 | &distribute_nat_info(); | ||||
| 19464 | 300 | 437 | find_subnets_in_zone(); | ||||
| 19465 | 300 | 398 | &set_service_owner(); | ||||
| 19466 | 300 | 436 | &expand_services(1); # 1: expand hosts to subnets | ||||
| 19467 | |||||||
| 19468 | # Abort now, if there are syntax errors and simple semantic errors. | ||||||
| 19469 | 300 | 414 | &abort_on_error(); | ||||
| 19470 | 226 | 327 | &expand_crypto(); | ||||
| 19471 | 226 | 305 | &check_unused_groups(); | ||||
| 19472 | 226 | 641 | set_policy_distribution_ip(); | ||||
| 19473 | 226 | 363 | &optimize_and_warn_deleted(); | ||||
| 19474 | 226 | 321 | &check_supernet_rules(); | ||||
| 19475 | 226 | 325 | prepare_nat_commands(); | ||||
| 19476 | 226 | 372 | find_active_routes(); | ||||
| 19477 | 226 | 330 | &gen_reverse_rules(); | ||||
| 19478 | 226 | 327 | &mark_secondary_rules(); | ||||
| 19479 | 226 | 296 | mark_dynamic_nat_rules(); | ||||
| 19480 | 226 | 292 | &abort_on_error(); | ||||
| 19481 | 208 | 276 | &set_abort_immediately(); | ||||
| 19482 | 208 | 299 | &rules_distribution(); | ||||
| 19483 | 208 | 318 | &local_optimization(); | ||||
| 19484 | 208 | 351 | if ($out_dir) { | ||||
| 19485 | 155 | 263 | &print_code($out_dir); | ||||
| 19486 | 155 | 253 | copy_raw($in_path, $out_dir); | ||||
| 19487 | } | ||||||
| 19488 | 208 | 297 | show_finished(); | ||||
| 19489 | 208 | 546 | return; | ||||
| 19490 | } | ||||||
| 19491 | |||||||
| 19492 | 1; | ||||||
| 19493 | |||||||
| 19494 | # LocalWords: Netspoc Knutzen internet CVS IOS iproute iptables STDERR Perl | ||||||
| 19495 | # LocalWords: netmask EOL ToDo IPSec unicast utf hk src dst ICMP IPs EIGRP | ||||||
| 19496 | # LocalWords: OSPF VRRP HSRP Arnes loop's ISAKMP stateful ACLs negatable | ||||||
| 19497 | # LocalWords: STDOUT | ||||||